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

Question

這是摘要：

下面是問題的詳細信息：

我有一個保存在名為shtSrc的工作表中的高中課程時間表。

時間表如下所示：

	一種	乙	C	D	乙	F
1	開始時間	時間結束	天	時期	主題	老師
2	上午 8:20:00	上午 9:10:00	星期日	1	地理	乙腦
3	上午 9:10:00	上午 10:00:00	星期日	2	歷史	蘇
4	上午 10:00:00	上午 10:40:00	星期日	3	商業	薩
5	上午 10:40:00	上午 11:40:00	星期日	4	休息
6	上午 11:40:00	12:30:00 下午	星期日	5	數學	上海
7	12:30:00 下午	下午 1:30:00	星期日	6	科學	菊
8	下午 1:30:00	晚上 8:20:00	星期日	7	額外課程
9	上午 8:20:00	上午 9:10:00	周一	1	商業	薩
10	上午 9:10:00	上午 10:00:00	周一	2	科學	蘇
11	上午 10:00:00	上午 10:40:00	周一	3	歷史	關於
12	上午 10:40:00	上午 11:40:00	周一	4	休息
13	上午 11:40:00	12:30:00 下午	周一	5	數學	上海
14	12:30:00 下午	下午 1:30:00	周一	6	地理	關於
15	下午 1:30:00	晚上 8:20:00	周一	7	額外課程
16	上午 8:20:00	上午 9:10:00	周二	1	商業	薩
17	上午 9:10:00	上午 10:00:00	周二	2	歷史	蘇
18	上午 10:00:00	上午 10:40:00	周二	3	地理	乙腦
19	上午 10:40:00	上午 11:40:00	周二	4	休息
20	上午 11:40:00	12:30:00 下午	周二	5	數學	上海
21	12:30:00 下午	下午 1:30:00	周二	6	科學	菊
22	下午 1:30:00	晚上 8:20:00	周二	7	額外課程

在這里，時間表顯示為 3 個工作日。 每天7個時段。 工作時間上午 8:20 至晚上 8:20。 一天教的科目順序每天都不一樣。

課程可能准時開始，也可能晚 10-15 分鍾。 課程實際開始的日期和時間記錄在名為shtDest的工作表的 A 列中。 該表如下所示：

	一種	乙	C	D	乙	F	G	H
1	入場日期和時間	入職日期	入場日	入場時間	開始時間	時期	主題	老師
2	2021/1/1 8:25
3	2021/1/3 9:25
4	1/3/2021 10:20
5	1/4/2021 13:30
6	1/5/2021 0:00

我使用一些 excel 公式和一些 VBA 填寫了表格的其余部分。 shtDest最終看起來像這樣：

	一種	乙	C	D	乙	F	G	H
1	入場日期和時間	入職日期	入場日	入場時間	開始時間	時期	主題	老師
2	2021/1/1 8:25	1/1/2021	星期五	上午 8:25
3	2021/1/3 9:25	1/3/2021	星期日	上午 9:25	上午 9:10:00	2	歷史	蘇
4	1/3/2021 10:20	1/3/2021	星期日	上午 10:20	上午 10:00:00	3	商業	薩
5	1/4/2021 13:30	1/4/2021	周一	下午 1:30	下午 1:30:00	7	額外課程
6	1/5/2021 0:00	1/5/2021	周二	12:00 AM

我在E2 中用來獲取開始時間的公式：

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

對於F2:H6 ，我使用了 VBA 的 Vlookup 替代方案。 這是代碼：

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

對於此代碼，我感謝此鏈接： VBA 中的索引匹配匹配/vlookup

主要問題是：

要運行此代碼，我必須在 E 列中提供 EXACT START TIME。要獲取 E 列中的值，我需要 3 個輔助列：B、C、D。我嘗試將Application.VLookup用於 E 列，但失敗了“類型不匹配”錯誤。

當我嘗試替換 IF 語句的第一行時

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

用這條線

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 _

我收到“類型不匹配”錯誤。

我想要：

我想在沒有任何公式、沒有任何輔助列、僅使用 VBA 的情況下實現相同的輸出。 是否可以使用數組或字典進行近似匹配？ 我的 shtSrc 有 20,000 多個條目。 你能建議任何方法替代 VLOOKUP WITH APPROXIMATE MATCH 而不使用Application.VLookup嗎？

Answer 1

當我將Timevalue轉換為 Double時，我想要包含的Vlookup 語句終於起作用了。 Vlookup 語句現在是：

        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 _

通過使用最后一行和最后一列的動態范圍選擇，最終的 VBA 代碼是：

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

最終輸出：

	一種	乙	C	D
1	入場日期和時間	時期	主題	老師
2	2021/1/1 8:25
3	2021/1/3 9:25	2	歷史	蘇
4	1/3/2021 10:20	3	商業	薩
5	1/4/2021 13:30	7	額外課程
6	1/5/2021 0:00