VLOOKUP() 使用数组的替代方法

Question

我一直在尝试使用数组来寻找比 VLOOKUP() 更快的替代方法，因为在处理非常大的数据集时可能需要很长时间。

我搜索了 SO 和许多其他网站，获取了 sn-ps 代码。

数据：

• A1:A5 要查找的值列表 (1,2,3,4,5)
• C1:C5 “查找”值的范围 (2,4,6,8,10)
• D1:D5 要“返回”的值范围 (a,b,c,d,e)

B1:B5 是我要粘贴“查找”值的位置。

代码工作到一定程度，因为它确实为 C1:C5 中“查找”值的 位置 以及 D1 中相邻单元格中的正确值返回正确值： D5。

当我尝试将返回值加载到Arr4（要粘贴回工作表的数组）时，当我将鼠标悬停在<Type mismatch> 上时。它不会阻止代码执行，但不会粘贴任何内容。

我的问题是：

1. 如何使用 myVal2 值填充数组 Arr4，以及
2. 如何将其粘贴回工作表？

Option Explicit
Sub testArray()
    Dim ArrLookupValues As Variant
    ArrLookupValues = Sheet1.Range("A1:A5")    'The Lookup Values
        
    Dim ArrLookupRange As Variant
    ArrLookupRange = Sheet1.Range("C1:C5")    'The Range to find the Value
        
    Dim ArrReturnValues As Variant
    ArrReturnValues = Sheet1.Range("D1:D5")    'The adjacent Range to return the Lookup Value
    
    Dim ArrOutput As Variant 'output array
        
    Dim UpperElement As Long
    UpperElement = UBound(ArrLookupValues)     'Used purely for the ReDim statement
        
    Dim i As Long
    For i = LBound(ArrLookupValues) To UBound(ArrLookupValues)
        Dim myVal As Variant
        myVal = ArrLookupValues(i, 1)
            
        Dim pos As Variant 'variant becaus it can return an error
        pos = Application.Match(myVal, ArrLookupRange, 0) 'pos always returns the correct position
            
        Dim myVal2 As Variant
        If Not IsError(pos) Then
            myVal2 = ArrReturnValues(pos, 1)           'myVal2 always returns the correct value
            ReDim Preserve ArrOutput(1 To UpperElement, 1 To 1)
            ArrOutput(i, 1) = myVal2
        Else
            ReDim Preserve ArrOutput(1 To UpperElement, 1 To 1)
            myVal2 = "Not Found"
            ArrOutput(i, 1) = myVal2
        End If
    Next i
        
    Dim Destination As Range
    Set Destination = Range("B1")
    Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value = 

    ArrOutput
End Sub

Answer 1

根据@T.M 的回答，您甚至可以不循环使用VLookup 而不是Match：

Public Sub testArraya()
    With Sheet1
        Dim ArrLookupValues() As Variant
        ArrLookupValues = .Range("A1:A5").Value        ' lookup values        1,2,3,4,5,6
    
        Dim ArrLookupReturnRange() As Variant          ' lookup range items   2,4,6,8,10
        ArrLookupReturnRange = .Range("C1:D5").Value   ' And return column D  a,b,c,d,e
    End With
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '[1] Match all values at once and return other values of column D
    '    (found position indices or Error 2042 if not found)
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dim ArrOutput() As Variant
    ArrOutput = Application.VLookup(ArrLookupValues, ArrLookupReturnRange, 2, 0)
    
    '[3] write results to any wanted target
    Dim Destination As Range
    Set Destination = Sheet1.Range("B1")         ' ‹‹ change to your needs
    Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value = ArrOutput     
End Sub

甚至是极短的，几乎是一条线：

Public Sub testArrayShort()
    Const nRows As Long = 5 'amount of rows
    
    With Sheet1
        .Range("B1").Resize(nRows).Value = Application.VLookup(.Range("A1").Resize(nRows).Value, .Range("C1:D1").Resize(nRows).Value, 2, 0)
    End With
End Sub

Answer 2

• 使用正确的错误处理和If 语句而不是On Error Resume Next。

• 您的Arr4 也需要像其他数组一样是二维的。即使它只有一列，也不必是Arr4(1 To UpperElement, 1 To 1) 和Arr4(i, 1) = myVal2。范围始终是二维的（行、列），即使只有一列。

我强烈建议重命名您的数组变量。当你觉得你必须给出你的可变数字时，你可以确定你做错了。

例如像下面这样重命名它们：

• Arr1 --› ArrLookupValues
• Arr2 --› ArrLookupRange
• Arr3 --› ArrReturnValues
• Arr4 --› ArrOutput

这只是一个简单的修改，但您的代码将极大地提高可读性和可维护性。您甚至不需要 cmets 来描述数组，因为它们的名称现在是自我描述的。

最后，您的输出数组可以声明为与输入数组相同的大小。使用ReDim Preserve 会使您的代码变慢，因此请避免使用它。

所以这样的事情应该可以工作：

Option Explicit

Public Sub testArray()
    Dim ArrLookupValues() As Variant
    ArrLookupValues = Sheet1.Range("A1:A5").Value
    
    Dim ArrLookupRange() As Variant
    ArrLookupRange = Sheet1.Range("C1:C5").Value
    
    Dim ArrReturnValues() As Variant
    ArrReturnValues = Sheet1.Range("D1:D5").Value

    Dim UpperElement As Long
    UpperElement = UBound(ArrLookupValues, 1)   
    
    'create an empty array (same row count as ArrLookupValues)
    ReDim ArrOutput(1 To UpperElement, 1 To 1)
    
    Dim i As Long
    For i = LBound(ArrLookupValues, 1) To UBound(ArrLookupValues, 1)
        Dim FoundAt As Variant 'variant because it can return an error
        FoundAt = Application.Match(ArrLookupValues(i, 1), ArrLookupRange, 0) 'pos always returns the correct position

        If Not IsError(FoundAt) Then
            ArrOutput(i, 1) = ArrReturnValues(FoundAt, 1)
        Else
            ArrOutput(i, 1) = "Not Found"
        End If
    Next i
    
    Dim Destination As Range
    Set Destination = Range("B1") 'make sure to specify a sheet for that range!
    Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value = ArrOutput
End Sub

Answer 3

只是为了好玩，对 @PEH 的有效方法稍作修改，展示了一种相当未知的方式来执行 单个 Match 检查两个数组而不是重复匹配：

Public Sub testArray()
    With Sheet1
        Dim ArrLookupValues As Variant
        ArrLookupValues = .Range("A1:A5").Value             ' lookup values      1,2,3,4,5,6
    
        Dim ArrLookupRange As Variant                       ' lookup range items 2,4,6,8,10
        ArrLookupRange = .Range("C1:C5").Value
    
        Dim ArrReturnValues As Variant                      ' return column D    a,b,c,d,e
        ArrReturnValues = .Range("D1:D5").Value
    End With
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    '[1] Match all item indices within ArrLookupRange at once 
    '    (found position indices or Error 2042 if not found)
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dim ArrOutput
    ArrOutput = Application.Match(ArrLookupValues, ArrLookupRange, 0)
    
    '[2] change indices by return values
    Dim i As Long
    For i = 1 To UBound(ArrOutput)
        If Not IsError(ArrOutput(i, 1)) Then
            ArrOutput(i, 1) = ArrReturnValues(ArrOutput(i, 1), 1)
'        Else
'            ArrOutput(i, 1) = "Not Found"       ' optional Not Found statement instead of #NV
        End If
    Next i

    '[3] write results to any wanted target
    Dim Destination As Range
    Set Destination = Sheet1.Range("B1")         '<< change to your needs
    Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value = ArrOutput
End Sub