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