Excel VBA- Iterate through columns in one workbook, pasting information in corresponding workbook

Running repeated lookups on a large range by looping through the cells or using Find() can be very slow. Depending on how many rows are being searched and how many lookups you’re running (and whether ID’s can be repeated in the lookup range) there are a few other options such as (eg) creating a “map” of the lookup data using a Dictionary, or using MATCH().

Here’s some code (below) to illustrate some different methods. I created a lookup column containing randomized numbers from 1 to 1048535 and then used different methods to run varying numbers of lookups on different-sized ranges.

Sample output when running 100 or 1000 lookups on a 100k-value range:

EDIT: added collection method (thanks Sid)

#### Searching: 100000      # lookups: 100
Loop          Map: 0        Lookup: 14.777              Total: 14.777
Loop (array)  Map: 0        Lookup: 0.711               Total: 0.711
Find          Map: 0        Lookup: 8.762               Total: 8.762
Dictionary    Map: 0.73     Lookup: 0.00391             Total: 0.73391
Collection    Map: 0.723    Lookup: 0                   Total: 0.723
Match         Map: 0        Lookup: 0.145               Total: 0.145



#### Searching: 100000      # lookups: 1000
Loop          Map: 0        Lookup: 150.984             Total: 150.984
Loop (array)  Map: 0        Lookup: 6.465               Total: 6.465
Find          Map: 0        Lookup: 82.527              Total: 82.527
Dictionary    Map: 0.602    Lookup: 0.00781             Total: 0.60981
Collection    Map: 0.672    Lookup: 0.00781             Total: 0.67981
Match         Map: 0        Lookup: 1.359               Total: 1.359

The basic “loop through the cells in-place” approach is the slowest of the methods tested: you can improve this approach >10-fold by instead looping over an array extracted from the lookup range.

Find() is consistently slow (only about twice as fast as the basic loop approach) and for large lookups is super-slow. Match() beats the Dictionary/Collection approaches for 100 lookups, but the Dictonary and Collection approaches scale better for larger numbers of lookups, since the “map” overhead is dependent only on the size of the lookup range, and each “lookup” operation is very fast..

Code:

Option Explicit

Sub SpeedTests()
    Const NUM_ROWS As Long = 100000 
    Const NUM_IDS As Long = 1000
    Dim rngLookup As Range, f As Range
    Dim d, d2, t, l As Long, v, t1, t2
    Dim arr, c As Range, ub As Long, rw As Long

    Set rngLookup = ActiveSheet.Range("A1").Resize(NUM_ROWS, 1)

    Debug.Print "#### Searching: " & NUM_ROWS, "# lookups: " & NUM_IDS

    'basic loop
    t = Timer
    For l = 1 To NUM_IDS
        For Each c In rngLookup.Cells
            If c.Value = l Then
            'found
            End If
        Next c
    Next l
    t2 = Round(Timer - t, 3)
    t1 = 0
    Debug.Print "Loop", "Map: 0", "Lookup: " & t2, "Total: " & (t1 + t2)

    'loop on array
    t = Timer
    arr = rngLookup.Value
    t1 = Round(Timer - t, 3)
    ub = UBound(arr, 1)
    For l = 1 To NUM_IDS
        For rw = 1 To ub
            If arr(rw, 1) = l Then
            'found
            End If
        Next rw
    Next l
    t2 = Round(Timer - t, 3)
    t1 = 0
    Debug.Print "Loop (array)", "Map: 0", "Lookup: " & t2, "Total: " & (t1 + t2)

    'regular use of Find()
    t = Timer
    For l = 1 To NUM_IDS
        Set f = rngLookup.Find(l, LookIn:=xlValues, lookat:=xlWhole)
        If Not f Is Nothing Then
            v = f.Row
        Else
            v = 0
        End If
    Next l
    t2 = Round(Timer - t, 3)
    t1 = 0
    Debug.Print "Find", "Map: 0", "Lookup: " & t2, "Total: " & (t1 + t2)

    'create a lookup map using a dictionary
    t = Timer
    Set d = GetMapDict(rngLookup)
    t1 = Round(Timer - t, 3)
    t = Timer
    For l = 1 To NUM_IDS
        If d.exists(l) Then
            v = d(l)
        Else
            v = 0
        End If
    Next l
    t2 = Round(Timer - t, 5)
    Debug.Print "Dictionary", "Map: " & t1, "Lookup: " & t2, "Total: " & (t1 + t2)
    Set d = Nothing

    'create a lookup map using a collection
    t = Timer
    Set d2 = GetMapCollection(rngLookup)
    t1 = Round(Timer - t, 3)
    t = Timer
    On Error Resume Next
    For l = 1 To NUM_IDS
        d2.Add 0, CStr(l)
        If Err.Number <> 0 Then
            'found!
            Err.Clear
        End If
    Next l
    t2 = Round(Timer - t, 5)
    Debug.Print "Collection", "Map: " & t1, "Lookup: " & t2, "Total: " & (t1 + t2)
    Set d = Nothing


    'use Match()
    t1 = 0
    t = Timer
    For l = 1 To NUM_IDS
        v = Application.Match(l, rngLookup, 0)
        If IsError(v) Then v = 0
    Next l
    t2 = Round(Timer - t, 3)
    Debug.Print "Match", "Map: " & t1, "Lookup: " & t2, "Total: " & (t1 + t2)

End Sub


Function GetMapCollection(rng) As Object
    Dim d As New Collection, v, arr, ub As Long, r As Long, r1 As Long
    Dim c As Range

    arr = rng.Value
    r1 = rng.Cells(1).Row
    ub = UBound(arr, 1)
    For r = 1 To ub
        v = arr(r, 1)
        If Len(v) > 0 Then
            On Error Resume Next
            d.Add r1 + (r - 1), CStr(v)
            On Error GoTo 0
        End If
    Next r
    Set GetMapCollection = d
End Function



Function GetMapDict(rng) As Object
    Dim d, v, arr, ub As Long, r As Long, r1 As Long
    Dim c As Range
    Set d = CreateObject("scripting.dictionary")
    arr = rng.Value
    r1 = rng.Cells(1).Row
    ub = UBound(arr, 1)
    For r = 1 To ub
        v = arr(r, 1)
        If Len(v) > 0 Then
            If d.exists(v) Then
                d(v) = d(v) & "|" & r1 + (r - 1)
            Else
                d.Add v, r1 + (r - 1)
            End If
        End If
    Next r
    Set GetMapDict = d
End Function