VBA-Perform lookup for all rows in column if date selected?

[Anita Knapp]

I am hoping to find a way to select a date at the top of a column and perform a look for all of the cells below it, and a different lookup for those one row to the right.

I have copied a bunch of things found and then went through chatgpt but what I'm getting from it isn't working. I originally was going to do this with xlookups on all of the cells which I finally got working, but the data behind it is huge and the user wont need all of them.

I've attached an example and the code I have is below. Also below are the formulas that work to pull the data in case that helps.

Left Column:'=XLOOKUP($D7&TEXT($E$6, "mm/dd/yyyy"),data[Helper], data[Result],0,0)  &  Right Column:'=XLOOKUP($D7&TEXT($K$6, "mm/dd/yyyyy"),data[Helper],data[Day]&CHAR(10)&TEXT(data[time], "hh:mm"))

Sub loaddata()

Dim ActiveCell As Range
Dim Lookup1 As Variant
Dim Lookup2 As Variant
Dim ec As Range
Dim Result As Variant
Dim ws As Workbook
Dim sc As Range
Dim ic As Range
Set sc = ThisWorkbook.Worksheets("data").Range("Helper")
Set ec = Sheets("data").Range("Day")
Set tc = Sheets("data").Range("Time")
Set res = Sheets("data").Range("Res")
Set ActiveCell = ActiveCell

'If Date selected in Row 5, perform for the two columns below
'how to set format for time hh:mm?
Lookup1 = LookupValue = ActiveCell.Offset(0, -1).Value
Lookup2 = ActiveCell.EntireColumn.Rows(3)

On Error Resume Next
'Primary Column Result
Result = Application.WorksheetFunction.XLookup(Lookup1 & Lookup2, sc, ec)
'One column to the right
Result = Application.WorksheetFunction.XLookup(Lookup1 & Lookup2, sc, res & tc)

On Error GoTo 0

If Not IsError(Result) Then
ActiveCell.Value = Result
Else: MsgBox "Didn't work"

End If


End Sub

[JohnTopley]

Several errors in the code:

Ws as Worksheet NOT WORKBOOK

Lookup1 and Lookup2 are not defined

Named ranges "Day", "Time" and "Res" not in the workbook

And why use text date comparisons rather than Excel dates which you have in row 3?

Please tell use exactly what you require to return: and what is "large" volume - how many rows?

[Anita Knapp]

Thank you so much for replying! I've been working on this for a couple weeks and it's driving me crazy. I've updated the code and file.

I think I fixed the Lookup1 and Lookup2 definitions but I'm not sure if I have the coding for that correct. The goal is if the user selects F5-O5, then it starts working in cell F6, doing a look up of the value of E6 and date in F5.

Res, Day, and time are columns H, I, J in the data tab.

I have the dates repeated in 3 and 5 because I was having issues with the formulas if they didn't have the TEXT conversion. Are you saying that I can just have my formatted date and it will read it?

Presently, the source files load with 70,000 rows and is filtered down to 22,000 rows in the data tab that is being used for this. This will double by the end of the year.

Thank you for your looking and tips is greatly appreciated!

Sub loaddata()

Dim ActiveCell As Range
Dim Lookup1 As Variant
Dim Lookup2 As Variant
Dim ec As Range
Dim Result As Variant
Dim sc As Range
Dim ic As Range
Set sc = ThisWorkbook.Worksheets("data").Range("Helper")
Set ec = Sheets("data").Range("Day")
Set tc = Sheets("data").Range("time")
Set res = Sheets("data").Range("Res")
Set ActiveCell = ActiveCell

'If Date selected in Row 5, perform for the two columns below
'how to set format for time hh:mm?
Lookup1 = LookupValue = ActiveCell.Offset(0, -1).Value
Lookup2 = ActiveCell.EntireColumn.Rows(3)

On Error Resume Next
'Primary Column Result
Result = Application.WorksheetFunction.XLookup(Lookup1 & Lookup2, sc, ec)
'One column to the right
Result = Application.WorksheetFunction.XLookup(Lookup1 & Lookup2, sc, res & tc)

On Error GoTo 0

If Not IsError(Result) Then
ActiveCell.Value = Result
Else: MsgBox "Didn't work"

End If


End Sub

[JohnTopley]

Please add some manually-calculated results to your workbook.

[Anita Knapp]

I've just updated it with what it would look like if 9/3 and 9/4 (J5-M5) were selected when the macro ran.

Thanks!

Please add some manually-calculated results to your workbook.

[JohnTopley]

Option Explicit
Sub LoadData()

Dim a, b
Dim dRng As Range, IDrng As Range
Dim sDate As Date, fDate As Date
Dim sRow As Long, nRow As Long, lRow As Long, r As Long, idx As Long, idy As Long

Application.ScreenUpdating = False

With Sheets("Data")
    .Activate
    Set dRng = .Range("E5:J" & .Cells(Rows.Count, "E").End(xlUp).Row)         ' Set DATA range
    dRng.Sort key1:=Range("G1"), order1:=xlAscending, Header:=xlYes           ' Sort by ascending Date
    a = dRng                                                                  ' Assign to array "a"
End With

ReDim b(1 To 1000, 1 To 62)                                                   ' Set output array : 62 columns for 31 days x 2 entries per day

With Sheets("Sep")
    .Activate
    
    Set IDrng = .Range("E6:E" & .Cells(Rows.Count, "E").End(xlUp).Row)        ' Personnel IDs
    sDate = .Range("F3"): fDate = Application.EoMonth(sDate, 0)               ' Month start date and month-end date
    
    sRow = Application.Match(CLng(sDate), dRng.Columns(3), 0)                 ' Start row of data for this month
    nRow = Application.CountIfs(dRng.Columns(3), ">=" & CLng(sDate), dRng.Columns(3), "<=" & CLng(fDate)) ' Number of rows (entries) for this month
    lRow = sRow + nRow - 1                                                    ' Last row of data for this month
    
    For r = sRow To lRow                                                      ' Loop through data for this month
        idx = Day(a(r, 3)) - 1                                                ' index for day in output array
        idy = Application.Match(a(r, 1), IDrng, 0)                            ' index (row) for personnel ID
        b(idy, idx * 2 + 1) = a(r, 4)                                         ' Result
        b(idy, (idx + 1) * 2) = a(r, 5) & " " & Format(a(r, 6), "hh:mm")      ' Day / time
    Next r
    
    .[F6].Resize(nRow, 62) = b                                                ' Output data
    .Columns("F:BO").HorizontalAlignment = xlCenter                           ' centre in columns
    .Columns("F:BO").ColumnWidth = 11                                         ' set column width
    
End With

Application.ScreenUpdating = True

End Sub

The data in "Sep" is sorted by DATE (column G) which makes the processing much faster. No helper column required.

Also assumes the list of personnel is in place (columns D:E in "Sep")

I assume the file does represent your actual file.

[Croweater]

I don't normally jump in on solved threads (it isn't is it?) or when someone else has done all the hard work (so apologies to John).

Your problem is that you are trying to match employee codes from one sheet in another and they don't exist where you are trying to get an exact match.

You need to handle this error in what is an appropriate way for your application (goto 'next r' maybe?).

[JohnTopley]

Option Explicit

Sub LoadData()

Dim a, b
Dim dRng As Range, IDrng As Range
Dim sDate As Date, fDate As Date
Dim sRow As Long, nRow As Long, lRow As Long, r As Long, idx As Long, idy As Variant

Application.ScreenUpdating = False

With Sheets("data")
    .Activate
    Set dRng = .Range("E5:J" & .Cells(Rows.Count, "E").End(xlUp).Row)         ' Set DATA range
    dRng.Sort key1:=Range("G1"), order1:=xlAscending, Header:=xlYes           ' Sort by ascending Date
    a = dRng                                                                  ' Assign to array "a"
End With

ReDim b(1 To 1000, 1 To 62)                                                   ' Set ouput array : 62 columns for 31 days x 2 entries per day

With Sheets("Sheet1")
    .Activate
    
    Set IDrng = .Range("E6:E" & .Cells(Rows.Count, "E").End(xlUp).Row)        ' Personnel IDs
    sDate = .Range("F3"): fDate = Application.EoMonth(sDate, 0)               ' Month start date and month-end date
    
    sRow = Application.Match(CLng(sDate), dRng.Columns(3), 0)                  ' Start row of data for this month
    nRow = Application.CountIfs(dRng.Columns(3), ">=" & CLng(sDate), dRng.Columns(3), "<=" & CLng(fDate)) ' Number of rows (entries) for this month
    lRow = sRow + nRow - 1                                                    ' Last row of data for this month
    
    For r = sRow To lRow                                                      ' Loop through data for this month
        idx = Day(a(r, 3)) - 1                                                ' index for day in output array
        idy = Application.Match(a(r, 1), IDrng, 0)                            ' index (row) for personnel ID
        If Not IsError(idy) Then
            b(idy, idx * 2 + 1) = a(r, 4)                                         ' Result
            b(idy, (idx + 1) * 2) = a(r, 5) & " " & Format(a(r, 6), "hh:mm")      ' Day / time
        Else
            MsgBox a(r, 1) & " not found"
        End If
    Next r
    
    .[F6].Resize(nRow, 62) = b                                                ' Output data
    .Columns("F:BO").HorizontalAlignment = xlCenter                           ' centre in columns
    .Columns("F:BO").ColumnWidth = 11                                         ' set column width
    
End With

Application.ScreenUpdating = True
End Sub

Updated with error handling: mea culpa!

[Anita Knapp]

It works! This is awesome, thanks!. Is there a way for it to only error if the ID on the month sheet isn't found on the data sheet? I have hundreds of ID's but if not, it looks like On Error Resume Next will work.

[JohnTopley]

Option Explicit

Sub LoadData()

Dim a, b
Dim dRng As Range, IDrng As Range, IDrngx As Range, rng As Range
Dim sDate As Date, fDate As Date
Dim sRow As Long, nRow As Long, lRow As Long, r As Long, idx As Long, idy As Variant

Application.ScreenUpdating = False

With Sheets("data")
    .Activate
    Set dRng = .Range("E5:J" & .Cells(Rows.Count, "E").End(xlUp).Row)         ' Set DATA range
    Set IDrng = .Range("E6:E" & .Cells(Rows.Count, "E").End(xlUp).Row)        ' Personnel IDs
    dRng.Sort key1:=Range("G1"), order1:=xlAscending, Header:=xlYes           ' Sort by ascending Date
    a = dRng                                                                  ' Assign to array "a"
End With

ReDim b(1 To 1000, 1 To 62)                                                   ' Set ouput array : 62 columns for 31 days x 2 entries per day

With Sheets("Sheet1")

    .Activate
    .Range("F6:BN" & .Cells(Rows.Count, "D").End(xlUp).Row).ClearContents
    
    Set IDrngx = .Range("E6:E" & .Cells(Rows.Count, "E").End(xlUp).Row)       ' Personnel IDs
    
    sDate = .Range("F3"): fDate = Application.EoMonth(sDate, 0)                ' Month start date and month-end date
    sRow = Application.Match(CLng(sDate), dRng.Columns(3), 0)                  ' Start row of data for this month
    nRow = Application.CountIfs(dRng.Columns(3), _
           ">=" & CLng(sDate), dRng.Columns(3), "<=" & CLng(fDate))            ' Number of rows (entries) for this month
    lRow = sRow + nRow - 1                                                     ' Last row of data for this month
 
    For Each rng In IDrngx
    
        idy = Application.Match(rng, IDrng, 0)                                 ' Check if iD is in "Data"
        If Not IsError(idy) Then                                               ' ID is in DATA
        
            For r = sRow To lRow                                                      ' Loop through data for this month
                idx = Day(a(r, 3)) - 1                                                ' index for day in output array
                idy = Application.Match(a(r, 1), IDrngx, 0)                           ' index (row) for personnel ID
                If Not IsError(idy) Then
                    b(idy, idx * 2 + 1) = a(r, 4)                                         ' Result
                    b(idy, (idx + 1) * 2) = a(r, 5) & " " & Format(a(r, 6), "hh:mm")      ' Day / time
                End If
            Next r
            
            .[F6].Resize(nRow, 62) = b                                                ' Output data
            .Columns("F:BO").HorizontalAlignment = xlCenter                           ' centre in columns
            .Columns("F:BO").ColumnWidth = 11                                         ' set column width
        Else
            MsgBox rng & " " & rng.Offset(0, -1) & " was not found in sheet DATA "
        End If
   
   Next rng
End With

Application.ScreenUpdating = True
End Sub

[Anita Knapp]

This is perfect, thanks so much!