Функция, предоставляемая @PGTester, прекрасно работала, когда в коде было решено несколько вопросов:
1) Объявления. Все объявления были в одной строке для каждого типа. Это не работает в VBA, поскольку только последняя переменная объявлена как предназначенная, а все предыдущие объявлены как вариант. (т. е. DIM adate, bdate, cdate в качестве даты) В этом примере только cdate является фактической датой. Передача adate функции приводила к несоответствию, пока объявления не были исправлены. (На это указал @Domenic)
2) Форматы дат: хотя все даты в исходном файле и файле перекрестных ссылок до форматирования были отформатированы как «гггг-ммм-дд», ошибка 13Несоответствие типов по-прежнему препятствовало продвижению кода вперед. Изменение формата на «md-yyyy» как в исходном файле (выполнено в коде), так и в таблице перекрестных ссылок (вручную перед доступом) решило проблему, и следующий код работал, как и ожидалось.
3) Указание вызовов функций в файле перекрестных ссылок как для vlookup, так и для rnglookup было выполнено путем создания и установки переменных для необходимых страниц. Это упростило выбор при необходимости.
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")
Выполнен код с обеими функциями:
Sub CleanDaily_Labour()
'
' CleanDaily_Labour Macro
' RMDC Payroll Resarch (MU) Report prep
'
' Note the separate declarations for each variable
'
Dim myPath As String, fName As String, refFILE As String, job As String, _
JobGR As String, DateST As String, WKDay As String, PDWK As String
Dim CRef As Workbook, wkb As Workbook
Dim shtDATE As Worksheet, shtJOB As Worksheet, sht As Worksheet
Dim aDate As Date, fYR As Date
Dim fYear As Variant
Dim rng As Range, rngJOBS As Range, rngJBGRP As Range
Dim SC As Long, lastRow As Long, PD As Long, WK As Long
' Application.ScreenUpdating = False
myPath = Application.ActiveWorkbook.Path
'
' Get the file date and assign to variables
'
Range("D3").Select
**Selection.NumberFormat = "m-d-yyyy"**
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 = "m-d-yyyy"
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)
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
'
sht.Activate
Range("A2:A" & lastRow).Value = fYear
Range("E2:E" & lastRow).Value = PDWK
Range("G2:G" & lastRow).Value = PD
Range("H2:H" & lastRow).Value = WK
'
' Close reference file
'
Application.DisplayAlerts = False
CRef.Close False
'
' Cleanup, save and close workbooks
'
Application.DisplayAlerts = False
wkb.SaveAs fName, 51
'
' SQL call: Load to existing datbase (GDrive), use same format as Transactions
' ?? Get sales by day? vs maintain PDWK - Future
'
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' wkb.Close.false
End Sub
Private Function VLookupVBA(what As Variant, lookupRng As Range, defaultValue As Variant) As Variant
Dim rv As Variant: rv = Application.VLookup(what, lookupRng, lookupRng.Columns.Count, False)
If IsError(rv) Then
VLookupVBA = "NULL"
Else
VLookupVBA = rv
End If
End Function
Public Sub UsageExample()
MsgBox VLookupVBA("ValueToFind", ThisWorkbook.Sheets("ReferenceSheet").Range("A:D"), "Not found!")
End Sub
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