Hi and thanks in advance for any help. Extracting daily files that have the date in a cell. I need to use the date to find which week it falls into in a table which has start and end dates in two columns. There is more data in subsequent columns I need to extract once I know the row the date falls into. The cross reference table is in this format: The date variable (assigned to both string and date variables) that is picked up from the source needs to be compared to col’s A and B to find out what row it would fit in then extract fiscal year (Col A) as well as short description (col F)
The adjusted and renamed destination file looks like this
This custom function is similar to Vlookup where it will compare the first two columns of a range as a date, and if the input date falls in the range, it will return the respective column.
Function rngLOOKUP(aDate As Date, rng As Range, theColumn As Long) As Variant Dim acell As Range For Each acell In rng.Columns(1).Cells If acell.Value <= aDate And acell.Offset(0, 1).Value >= aDate Then rngLOOKUP = acell.Offset(0, theColumn - 1).Value Exit Function End If Next acell rngLOOKUP = "#Nothing" End Function
In this excel file, you can see it in action. Or see below screenshot. The highlight cell has the custom formula.
The functionality described here can be accomplished via cell formulas without resorting a VBA function. I included 2 possible solutions.
I have simplified the scenario a bit. Assume that the cross reference table (located in Sheet1 of a XR.xlsx file) only contains these 3 columns:
A B C +--------------+---------------+---------------+ 1 | PDWK_St_Date | PDWK_End_Date | Short_Descrip | +--------------+---------------+---------------+ 2 | 07-Nov-16 | 13-Nov-16 | P1W1 | 3 | 14-Nov-16 | 20-Nov-16 | P1W2 | 4 | 21-Nov-16 | 27-Nov-16 | P1W3 | 5 | 28-Nov-16 | 04-Dec-16 | P1W4 | 6 | 05-Dec-16 | 11-Dec-16 | P2W1 | 7 | 12-Dec-16 | 18-Dec-16 | P2W2 | 8 | 19-Dec-16 | 25-Dec-16 | P2W3 | 9 | 26-Dec-16 | 01-Jan-17 | P2W4 | 10 | 02-Jan-17 | 08-Jan-17 | P3W1 | 11 | 09-Jan-17 | 15-Jan-17 | P3W2 | 12 | 16-Jan-17 | 22-Jan-17 | P3W3 | 13 | 23-Jan-17 | 29-Jan-17 | P3W4 | 14 | 30-Jan-17 | 05-Feb-17 | P4W1 | 15 | 06-Feb-17 | 12-Feb-17 | P4W2 | 16 | 13-Feb-17 | 19-Feb-17 | P4W3 | 17 | 20-Feb-17 | 26-Feb-17 | P4W4 | 18 | 27-Feb-17 | 05-Mar-17 | P5W1 | +--------------+---------------+---------------+
Solution 1 (simplified)
It only works if the date ranges are consecutive (i.e. start date = end date from previous row + 1 day) – his is the case in your cross reference table.
In your destination workbook, use VLOOKUP to refer to the cross reference table:
The above formula is specific to row 2 in the destination table and assumes the “Business Date” is in column B (hence
B2 in the 1st parameter), 2nd parameter is the lookup range, 3 in the 3rd parameter means the value to retrieve is in the 3rd column and TRUE allows date matching within a range (from start date to the next row’s start date).
Note that the formula can be easily replicated to other rows, e.g. by dragging the fill handle (the small square in the cell’s bottom-right corner).
In this approach, the business date is compared against both start and end dates from the cross-reference table. Instead of
VLOOKUP, it uses
Here, the business date (cell
B2) is compared against both start and end date, the results are multiplied (equivalent to logical AND) and matched against 1 (i.e. TRUE).
IMPORTANT: After pasting this formula (e.g. into formula bar for cell
C2) you need to hit
Ctrl+Shift+Enter instead of the usual
Enter. This is to indicate a so-called “array formula” (aka CSE formula); otherwise, our comparisons inside MATCH wouldn’t work as intended. You may refer to this post for more info. The CSE formulas show surrounded by braces in the formula bar. The good news is that they can be replicated just like all other formulas.
The destination table will look similar to:
A B C +------+---------------+-------------+ 1 | Unit | Business Date | Short Descr | +------+---------------+-------------+ 2 | 1102 | 26-Aug-17 | #N/A | 3 | 1102 | 05-Jan-17 | P3W1 | 4 | 1102 | 06-Feb-17 | P4W2 | 5 | 1102 | 11-Nov-16 | P1W1 | 6 | 1102 | 02-Feb-17 | P4W1 | 7 | 1102 | 01-Oct-16 | #N/A | +------+---------------+-------------+
Note that in case of solution 1, cell
C2 would contain P5W1 instead of #N/A – this is because no end date was used in comparison.
The Function Provided by @PGTester worked great once a couple of issues were dealt with in the code:
1) Declarations: The declarations were all on one line for each type. This does not work in VBA as only the last variable is declared as intended and all previous ones are declared as variant. (ie, DIM adate, bdate, cdate as date) In this example only cdate is an actual date. Passing adate to the function resulted in a mismatch until the declarations were corrected. (This was pointed out by @Domenic)
2) Date formats: While all dates in the source file and the cross reference file were formatted as “yyyy-mmm-dd” prior to calling the function, Error 13, Type Mismatch still prevented the code from moving forward. Changing the format to “m-d-yyyy” on both the source file (done in code) and the cross reference table (manually prior to accessing) solved the issue and the following code worked as expected.
3) Pointing the function calls at the cross reference file for both the vlookup and rnglookup was done by building and setting variables to the pages needed. This simplified the selections when required.
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")
Completed code with both functions follows:
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