VBA 中 DATE AND TIME 与 APROXIMATE MATCH 等效的 Vlookup

Question

Here is the summary:

Here is the problem in details:

I have a high school class time table saved in a worksheet named shtSrc .

The time table looks like this:

	A	B	C	D	E	F
1	Start Time	End Time	Day	Period	Subject	Teacher
2	8:20:00 AM	9:10:00 AM	Sunday	1	GEOGRAPHY	JE
3	9:10:00 AM	10:00:00 AM	Sunday	2	HISTORY	SU
4	10:00:00 AM	10:40:00 AM	Sunday	3	BUSINESS	SA
5	10:40:00 AM	11:40:00 AM	Sunday	4	BREAK
6	11:40:00 AM	12:30:00 PM	Sunday	5	MATHS	SH
7	12:30:00 PM	1:30:00 PM	Sunday	6	SCIENCE	JU
8	1:30:00 PM	8:20:00 PM	Sunday	7	EXTRA CLASS
9	8:20:00 AM	9:10:00 AM	Monday	1	BUSINESS	SA
10	9:10:00 AM	10:00:00 AM	Monday	2	SCIENCE	SU
11	10:00:00 AM	10:40:00 AM	Monday	3	HISTORY	RE
12	10:40:00 AM	11:40:00 AM	Monday	4	BREAK
13	11:40:00 AM	12:30:00 PM	Monday	5	MATHS	SH
14	12:30:00 PM	1:30:00 PM	Monday	6	GEOGRAPHY	RE
15	1:30:00 PM	8:20:00 PM	Monday	7	EXTRA CLASS
16	8:20:00 AM	9:10:00 AM	Tuesday	1	BUSINESS	SA
17	9:10:00 AM	10:00:00 AM	Tuesday	2	HISTORY	SU
18	10:00:00 AM	10:40:00 AM	Tuesday	3	GEOGRAPHY	JE
19	10:40:00 AM	11:40:00 AM	Tuesday	4	BREAK
20	11:40:00 AM	12:30:00 PM	Tuesday	5	MATHS	SH
21	12:30:00 PM	1:30:00 PM	Tuesday	6	SCIENCE	JU
22	1:30:00 PM	8:20:00 PM	Tuesday	7	EXTRA CLASS

Here, the schedule is demonstrated for 3 working days. 7 time slots per day. Working hours 8:20 AM to 8:20 PM. The order of subjects taught on a day is not the same everyday.

Classes may start on time, or 10-15 minutes later. The date and time when a class actually started was recorded in column A of a worksheet named shtDest . The sheet looks like this:

	A	B	C	D	E	F	G	H
1	Entry date and time	Entry date	Entry day	Entry time	Start Time	Period	Subject	Teacher
2	1/1/2021 8:25
3	1/3/2021 9:25
4	1/3/2021 10:20
5	1/4/2021 13:30
6	1/5/2021 0:00

I filled up rest of the table using some excel formula and some VBA. The shtDest finally looked like this:

	A	B	C	D	E	F	G	H
1	Entry date and time	Entry date	Entry day	Entry time	Start Time	Period	Subject	Teacher
2	1/1/2021 8:25	1/1/2021	Friday	8:25 AM
3	1/3/2021 9:25	1/3/2021	Sunday	9:25 AM	9:10:00 AM	2	HISTORY	SU
4	1/3/2021 10:20	1/3/2021	Sunday	10:20 AM	10:00:00 AM	3	BUSINESS	SA
5	1/4/2021 13:30	1/4/2021	Monday	1:30 PM	1:30:00 PM	7	EXTRA CLASS
6	1/5/2021 0:00	1/5/2021	Tuesday	12:00 AM

The formula I used in E2 to get the start time:

=IFERROR(VLOOKUP(D2,IF(shtSrc!$C$2:$C$22=C2,shtSrc!$A$2:$F$22,""),1,TRUE),"")

For F2:H6 , I used a Vlookup alternative with VBA. Here is the code:

Option Explicit

Sub VlookupAlternative()
    Dim rngSrc As Range, rngDest As Range, celSrc As Range, celDest As Range
    

    With ThisWorkbook
        Set rngSrc = .Worksheets("shtSrc").Range("$A$1:$F$22")
        Set rngDest = .Worksheets("shtDest").Range("$F$2:$H$6")
        
        ' Compare top headers and left headers respectively. If matching, copy the value in destination table.
        For Each celDest In rngDest
            For Each celSrc In rngSrc
            
'         ***   This is the line I want as first line in the IF statement:
'         ***   If .Worksheets("shtSrc").Cells(celSrc.Row, 1).Value = Application.VLookup(Format(CLng(CDate(.Worksheets("shtDest").Cells(celDest.Row, 1).Value)), "h:mm:ss AM/PM"), rngSrc, 1, True) And _

                If .Worksheets("shtSrc").Cells(celSrc.Row, 1).Value = .Worksheets("shtDest").Cells(celDest.Row, 5).Value And _
                        .Worksheets("shtSrc").Cells(celSrc.Row, 3).Value = Format(.Worksheets("shtDest").Cells(celDest.Row, 1).Value, "DDDD") And _
                        .Worksheets("shtSrc").Cells(1, celSrc.Column).Value = .Worksheets("shtDest").Cells(1, celDest.Column).Value Then
                    celDest.Value = celSrc.Value
                End If
            Next celSrc
        Next celDest
    End With
End Sub

For this code I am thankful to this link: Index match match/vlookup in VBA

The main issue is:

To run this code, I have to provide EXACT START TIME in column E. And to get the values in column E, I need 3 helper columns: B, C, D. I tried using Application.VLookup for column E but I failed with "Type Mismatch" Error.

When I tried replacing the first line of the IF statement

If .Worksheets("shtSrc").Cells(celSrc.Row, 1).Value = .Worksheets("shtDest").Cells(celDest.Row, 5).Value And _

with this line

If .Worksheets("shtSrc").Cells(celSrc.Row, 1).Value = Application.VLookup(Format(CLng(CDate(.Worksheets("shtDest").Cells(celDest.Row, 1).Value)), "h:mm:ss AM/PM"), rngSrc, 1, True) And _

I got a "Type Mismatch" error.

I want to:

I want to achieve the same output without any formula, without any helper columns, using only VBA . Is approximate match possible using arrays or dictionaries ? My shtSrc has 20,000+ entries. Can you suggest any way alternative to VLOOKUP WITH APPROXIMATE MATCH without using Application.VLookup ?

Answer 1

The Vlookup statement I wanted to include finally worked when I converted Timevalue to Double . The Vlookup statement now is:

        If .Worksheets("shtSrc").Cells(celSrc.Row, 1).Value = Application.IfError(Application.VLookup(CDbl(TimeValue(.Worksheets("shtDest").Cells(celDest.Row, 1).Value)), rngSrc, 1, True), "") And _

With a dynamic range selection using last row and last column, The final VBA code is:

Option Explicit

Sub VlookupAlternative()
    
    Const INPUT_SHT = "shtSrc"
    Const OUTPUT_SHT = "shtDest"
    
    
    Dim wb As Workbook, wsIn As Worksheet, wsOut As Worksheet
    Dim rngSrc As Range, rngDest As Range, celSrc As Range, celDest As Range
    Dim rLastIn As Long, cLastIn As Long
    Dim rLastOut As Long, cLastOut As Long

    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    On Error Resume Next
    
    Set wb = ThisWorkbook
    Set wsIn = wb.Sheets(INPUT_SHT)
    Set wsOut = wb.Sheets(OUTPUT_SHT)
    
    
    rLastIn = lastRow(wsIn)
    cLastIn = LastCol(wsIn)
    
    rLastOut = lastRow(wsOut)
    cLastOut = LastCol(wsOut)
    
    With wb

        Set rngSrc = wsIn.Range("$A$2:$F$" & rLastIn)
        Set rngDest = wsOut.Range("$B$2:$D$" & rLastOut)
        
        
        ' Compare top headers and left headers respectively. If matching, copy the value in destination table.
        For Each celDest In rngDest
            For Each celSrc In rngSrc
                If wsIn.Cells(celSrc.Row, 1).Value = Application.IfError(Application.VLookup(CDbl(TimeValue(wsOut.Cells(celDest.Row, 1).Value)), rngSrc, 1, True), "") And _
                    wsIn.Cells(celSrc.Row, 3).Value = Format(wsOut.Cells(celDest.Row, 1).Value, "DDDD") And _
                    wsIn.Cells(1, celSrc.Column).Value = wsOut.Cells(1, celDest.Column).Value Then
                    celDest.Value = celSrc.Value
                End If
            Next celSrc
        Next celDest
    End With
    
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub


Function lastRow(sh As Worksheet)
    On Error Resume Next
    lastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

Final output:

	A	B	C	D
1	Entry date and time	Period	Subject	Teacher
2	1/1/2021 8:25
3	1/3/2021 9:25	2	HISTORY	SU
4	1/3/2021 10:20	3	BUSINESS	SA
5	1/4/2021 13:30	7	EXTRA CLASS
6	1/5/2021 0:00