Так близко к завершению большого проекта, но, похоже, не могу преодолеть это несоответствие. Любая помощь будет оценена. Надеюсь, что это не слишком много информации ...
Получение файла .xlsx с одним листом и необходимо добавить информацию к данным в новой книге, используя таблицу перекрестных ссылок для получения бизнес-дат и периодов. Вот пример исходной книги:
Пример фрагмента данных
Я получил этот код от @PGSystemTester в качестве решения vlookup для извлечения данных из справочной таблицы с помощьюдата, которая попадает между датами в отдельных столбцах справочной таблицы.
Function rngLOOKUP(chkDate As Date, rngf As Range, theColumn As Long) As Variant
Dim acell As Range
For Each acell In rngf.Columns(1).Cells
If acell.Value <= chkDate And acell.Offset(0, 1).Value >= chkDate Then
rngLOOKUP = acell.Offset(0, theColumn - 1).Value
Exit Function
End If
Next acell
rngLOOKUP = "#Nothing"
End Function
Я искал и пробовал десятки методов для форматирования даты, но не могу преодолеть несоответствие типов, и начинаю задумываться, а нена самом деле это дата выпуска:
Вот пример таблицы перекрестных ссылок:
Образец таблицы перекрестных ссылок
Каждый раз, когда яиспользуйте этот вызов, чтобы присвоить результат переменной. Я получаю ошибку времени выполнения 13, несоответствие типов:
fYear = rngLOOKUP(aDate, rng, 3)
Вот полный код. Исходный файл - .xlsx, и я форматирую ячейку, из которой берется дата, перед тем, как присвоить ее переменной.
Sub CleanDaily_Labour()
'
' CleanDaily_Labour Macro
' RMDC Payroll Resarch (MU) Report prep
'
Dim myPath, fName, refFILE, job, JobGR, DateST, WKDay, PDWK, fYear As String
Dim CRef, wkb As Workbook
Dim shtDATE, shtJOB, sht As Worksheet
Dim aDate, fYR As Date
Dim rngLOOKUP As Variant
Dim rng, rngJOBS, rngJBGRP As Range
Dim SC, lastRow, PD, WK As Long
Application.ScreenUpdating = False
myPath = Application.ActiveWorkbook.Path
'
' Get the file date and assign to variables
'
Range("D3").Select
Selection.NumberFormat = "yyyy-mm-dd"
aDate = Range("D3").Value
DateST = WorksheetFunction.Text(aDate, "YYYYMMDD")
WKDay = WorksheetFunction.Text(aDate, "DDD")
Selection.Copy
Range("D7").Select
ActiveSheet.Paste
'
' Rename and save the active workbook by date
' set wkb to new workbook name and assign calendar cross ref
'
fName = myPath & "\Daily_Labour" _
& DateST & ".xlsx"
ActiveWorkbook.SaveAs fName, 51
Set wkb = Workbooks.Open(fName)
Set sht = wkb.Sheets("Sheet1")
refFILE = myPath & "\Cross_Ref_fCalendar.xlsx"
'
' Remove extra header info
'
Rows("1:5").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
'
' Insert Column to the left of Column D
'
Columns("E:G").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromRightOrBelow
'
' Update Headers that will be kept / used
'
Range("A1").Value = "FYear"
Range("E1").Value = "PD_WK"
Range("J1").Value = "JOB_GRP"
Range("F1").Value = "WKDay"
Range("G1").Value = "PD"
Range("H1").Value = "WK"
'
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
End With
'
' Remove extra columns
'
Sheets("Sheet1").Range("K:K,M:P,R:AY").EntireColumn.Delete
'
' Get the last row and fill known columns
'
lastRow = Cells(Rows.Count, 1).End(xlUp).row
Range("d2:d" & lastRow).Value = aDate
'Range("d2:d" & lastRow).NumberFormat = "dd-mmm-yy" (commented as no impact on error, tried variantions here to overcome mismatch but should not matter as variable never changed here, just the range)
Range("f2:f" & lastRow).Value = WKDay
'
' Set variables for next steps
'
Set CRef = Workbooks.Open(refFILE)
Set shtJOB = CRef.Sheets("JobCross")
Set shtDATE = CRef.Sheets("fcalendar")
sht.Activate
Set rngJOBS = Range("i2:i" & lastRow)
Set rngJBGRP = shtJOB.Range("A1:b16")
Set rng = shtDATE.Range("A2:f210")
'
' Loop through jobs in column i match job in shtJOB
' put matching group in row j (Use Function vLookupVBA)
'
For Each jRow In rngJOBS
jRow.Select
job = ActiveCell.Value
JobGR = VLookupVBA(job, rngJBGRP, Null)
ActiveCell.Offset(0, 1).Value = JobGR
'end for
Next jRow
'
'Save Progress during testing:
'
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fName, 51
'
' Fill in date parameters from Cross Ref file for Business date
' Use function rngLOOKUP to update variables then set ranges to the variables
' May be more efficient to get row number from cross ref table instead - later.
'
' shtDATE.Activate (does not seem to affect)
'
fYear = rngLOOKUP(aDate, rng, 3) '**This results in the error**
PDWK = rngLOOKUP(aDate, rng, 6)
PD = rngLOOKUP(aDate, rng, 4)
WK = rngLOOKUP(aDate, rng, 5)
'
' Fill the columns with the variables (can likely bypass the variables and put on 1 line)- later
'
Range("A2:A" & lastRow).Value = fYear
Range("E2:E" & lastRow).Value = PDWK
Range("G2:G" & lastRow).Value = PD
Range("H2:H" & lastRow).Value = WK
'
' Cleanup, save and close workbooks
'
Application.DisplayAlerts = False
CRef.Close False
wkb.SaveAs fName, 51
'
' SQL call: Load to existing datbase (GDrive), use same format as Transactions
' ?? Get sales by day? vs maintain PDWK
'
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub