VLOOKUP() 替代使用数组

Question

我一直在尝试使用数组来找到 VLOOKUP() 的更快替代方法，它可能需要很长时间才能执行非常大的数据集。

我搜索了 SO 和许多其他网站，抓取了代码片段。

数据：

• 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

根据@TM 的回答，您甚至可以通过使用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

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

最后，您的输出数组可以声明为与输入数组相同的大小。 使用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