VLOOKUP() Alternative using Arrays

问题

I’ve been experimenting with arrays in an effort to find a faster alternative to VLOOKUP(), which can take a long time to execute with very large data sets. Arrays are not my forte, and I’m stuck on the code below. I have searched SO and many other sites, grabbing snippets of code here and there, but I’ve hit a brick wall when it comes to putting it all together.

The data is simply:

A1:A5 the list of values to lookup (1,2,3,4,5)
C1:C5 the range to ‘find’ the values (2,4,6,8,10)
D1:D5 the range of values to ‘return’ (a,b,c,d,e)

B1:B5 is where I’d like to paste the ‘looked-up’ values.

The code works up to a point, in that it does return correct values for the ‘looked-up’ value’s position in C1:C5 – and the correct values in the adjacent cells in D1:D5. The problem seems to start when I try to load the returned values to Arr4 (the array to be pasted back to the sheet) which is saying <Type mismatch> when I hover the mouse over it. It doesn’t stop the code from executing, but it doesn’t paste anything back to the sheet.

My questions are:

How do I populate the array Arr4 with the myVal2 values, and
How do I paste it back to the sheet?

Any guidance would be greatly appreciated.

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

回答1:

Use proper error handling and an If statement instead of On Error Resume Next.
Also your Arr4 needs to be 2 dimensional like your other arrays. Even if it is only one column it needs no be Arr4(1 To UpperElement, 1 To 1) and Arr4(i, 1) = myVal2. Ranges are always 2 dimensional (row, column) even if there is only one column.

And I highly recommend to rename your array variables. When ever you feel like you have to give your variable numbers, you can be sure you are doing it wrong.

Rename them like following for example:

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

This is only a simple modification but your code will extremely gain in human readability and maintainability. You even don't need comments to describe the arrays because their names are self descriptive now.

Finally your output array can be declared the same size as the input arrays. Using ReDim Preserve makes your code slow, so avoid using it.

So something like this should work:

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

回答2:

According to @T.M 's answer, you can even do that without looping just by using VLookup instead of 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

Or even extremly shortened and almost a one liner:

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

回答3:

Just for fun a slight modification of @PEH 's valid approach demonstrating a rather unknown way to excecute a single Match checking both arrays instead of repeated matches:

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

来源：https://stackoverflow.com/questions/64748492/vlookup-alternative-using-arrays

标签

arrays

excel

vba