VBA 中的 Vlookup 等效项与 ARRAYS 中的近似匹配答案

【问题标题】：Vlookup equivalent in VBA with APROXIMATE MATCH in ARRAYSVBA 中的 Vlookup 等效项与 ARRAYS 中的近似匹配
【发布时间】：2021-07-04 06:08:27
【问题描述】：

问题总结如下：

我提出了以下 VBA 代码，这些代码运行良好，但运行时间过长。所以，我正在尝试处理所有输入数组的数据。但我被 Vlookup APROXIMATE MATCH in ARRAYS 卡住了。

有效的 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

我尝试用数组编写的代码：

Option Explicit

Sub VlookupAlternativeArray()
    
    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, rngLookup As Range, rngReturn As Range
    Dim celSrc As Range, celDest As Range
    Dim rLastIn As Long, cLastIn As Long
    Dim rLastOut As Long, cLastOut As Long
    Dim lookupArray As Variant, returnArray As Variant, destArray As Variant

    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)
    
    Set rngLookup = wsIn.Range("$A$2:$C$" & rLastIn)
    Set rngReturn = wsIn.Range("$D$2:$F$" & rLastIn)
    Set rngDest = wsOut.Range("$B$2:$D$" & rLastOut)

    
    lookupArray = rngLookup.Value2
    returnArray = rngReturn.Value2
    destArray = rngDest.Value2

'**********I want to put a vlookup approximate equivalent code here.*************************************************

                                            '    Dim desc As String
                                            '    Dim i As Long
                                            '    Dim j As Long
                                            '    For i = LBound(destArray, 1) To UBound(destArray, 1)
                                            '        desc = destArray(i, 1)
                                            '        For j = LBound(lookupArray, 1) To UBound(lookupArray, 1)
                                            '            If InStr(1, desc, lookupArray(j, 1), vbTextCompare) > 0 Then
                                            '                destArray(i, 2) = returnArray(j, 1)
                                            '                Exit For
                                            '            End If
                                            '        Next j
                                            '    Next i
'*********************************************************************************************************************

    wsOut.Range("B2").Resize(UBound(destArray, 1), 1).Value2 = Application.Index(destArray, 0, 2)

    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

作为 VBA 的初学者，我需要指导如何在 ARRAYS 中处理 Vlookup APPROXIMATE MATCH。 Application.Vlookup 在数组中工作吗？ VBA 字典在这里是更好的选择吗？任何代码示例或建议将不胜感激。

如果需要参考代码的上下文，详细here。

【问题讨论】：

标签： arrays excel vba

【解决方案1】：

VBA 中没有与 VLOOKUP 等效的功能。相反，VBA 可以使用 Excel 自己的 VLOOKUP，但不能使用它的 ISERROR() 函数。您的代码运行缓慢，因为它在每次尝试运行您的公式时都会崩溃，并且On Error Resume Next 会阻止它停止。它不起作用。而且它不能工作，因为 ISERROR 条件不仅不能在 VBA 中工作，而且在你的公式中也没有意义。

不清楚您想要达到什么目标，但如果您需要近似匹配，请考虑使用 Application.Match 或使用 Range.Find 以获得精确匹配。

请注意，wsIn.Cells(celSrc.Row, 1) 和 wsOut.Cells(celDest.Row, 1) 限定了范围 celSrc 和 celDest。此外，考虑单元格的 Value、Value2、Formula 及其显示之间的差异。在搜索日期或时间时，Value2 包含一个数字，Value 包含该数字的格式化表达式（显示的值）。 Formula 可能包含 Value2 或创建 Value2 的函数的副本。

同时搜索数字和格式是没有意义的，因为它们本质上是相同的。但是您确实需要知道您正在寻找哪种格式的搜索标准以及在哪个属性中找到它。 VBA 的Range.Find 允许您在值或公式中进行搜索，后者允许您访问Value2（如果搜索数据中没有使用任何函数）。

最后，通过将 WorksheetFunction.Match 结果分配给变体数据类型的变量，例如 ...

Dim Match As Variant
Match = Application.Match(celSrc.Value, RngDest, 0)

匹配失败将导致vbError 被分配给变量。您可以使用 ... 捕获该错误

If Match = vbError Then
    Match = 1      ' rectify the condition
End if

这里不涉及On Error Resume Next，因为 Variant 本身可以存储错误。请注意，如果您使用 WorksheetFunction.Match 或将返回值分配给 Long 数据类型的变量，这将不起作用。仅在您知道会出现哪个错误并已为您的代码处理它做好准备的情况下才使用On Error Resume Next。不要预防性地使用它。它不起作用，如此处所示。相反，它会蒙住你的眼睛。

最后，对工作表的每次引用都很慢。因此，如果可以对数组而不是单元格进行许多引用，代码将运行得更快。实际上，您可以将查找值加载到数组中，但不能将查找范围加载。现在，您的问题不在于 VLOOKUP 不适用于数组 - 实际上它不是因为数组是 VBA 而范围是 Excel - 但您的查找不起作用。先让你的函数工作，然后开始担心速度。

【讨论】：

@Ted Williams 感谢您向我指出这个错字。我本来打算Application.Match 并更正了sn-p。
能否请您看一下我稍后添加的问题摘要？我很感谢你的 cmets。作为 VBA 的初学者，我已尽力遵循您的建议。我已经使用错误捕获摆脱了 On Error Resume Next 。但是 WorksheetFunction.Match 并没有改善我的输出。是否可以使用数组或字典从两列中定义的时间范围（例如“9:10:00 AM - 10:00:00 AM”）中查找“9:25 AM”？我需要一些指导。

【解决方案2】：

请阅读 Excel 中日期和时间的表示。您会发现 ShSrc!A2 中的 "03/01/2021 08"20 AM" 实际上是对数字 44199.3472222222 的解释，其中 44199 描述了一天，而 0.347222222 是时间的一部分（表示 24 小时 =1） . 这个数字是那个单元格的Value，格式为“mm/dd/yyyy hh:mm AM/PM”。

因此，C2 中的公式是（或应该是）=A2，custom 单元格格式为 dddd，它将显示与“星期日”相同的基础数字。

进一步表明，ShSrc!A:B 中的所有时间都应该是日期/时间值，而不是省略日期的单纯时间值。这是我们在这里不处理的数据捕获问题。这同样适用于单元格 ShDest!A2。

现在您的所有数据都是真实的日期/时间，您可以搜索和比较它们。这是 ShDest!B2 的公式。

=VLOOKUP($A2, ShSrc!$A$2:$F$5,COLUMN()+2,TRUE)

公式在 B 列中。因此COLUMN() 返回数字 2。ShSrc!$A$2:$F$5 中的查找列是 D 列，其数字 4 等于 COLUMN()+2 你在公式中找到。这个小技巧可以让您将公式从 ShDest!B2 复制到 C2:D2，其中 COLUMN() 更改为 3、4 和 5，而 COLUMN() + 2 更改为 5、6 和 7。

坦率地说，我看不出我们如何将上述内容与您的请求联系起来以帮助编写代码。不久的将来需要确定是否需要以及为什么需要代码，如果答案是肯定的，那么您可能提出的任何问题都必须考虑到上述内容，也就是说，包括您的数据的性质。

【讨论】：