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

Question

I have current data in one workbook and archived data in another workbook. In column "B" of Recent Data Workbook I have an ID variable. I want to say:

For each of the IDs in Column B of the Recent Data, Iterate through all of the rows in Column A of the Archived Workbook. If there is a match, than copy various column entries of Recent Data Workbook into the Archived Workbook.

I wrote working code, but the problem is that, in the Archived Data workbook there is 1,048,575 rows and so the For loops run extremely slowly for each match. Is there a better way to think about this?

Here is my current code:

Sub CopyDataLines()
    Dim wb As Workbook, wb2 As Workbook
    Dim ws As Worksheet
    Dim vFile As Variant
    Dim Filter As String
    Dim FilterIndex As Integer
    Dim Pupid As String

    'Set source workbook
    Set wb = ActiveWorkbook
    Set wbSheet = ActiveSheet

    'Filters for allowed files
    Filter = "Excel Later Versions (*.xlsx),*.xlsx," & _
             "Excel Files (*.xls),*.xls,"

    FilterIndex = 1

    'Open the target workbook
    vFile = Application.GetOpenFilename(Filter, FilterIndex, "Select One File to Open", , False)

    'if the user didn't select a file, exit sub
    If TypeName(vFile) = "Boolean" Then Exit Sub

    'Else open the file
    Workbooks.Open vFile

    'Set worbook to copy from
    Set wb2 = ActiveWorkbook
    Set wb2sheet = ActiveSheet

    With wb2.ActiveSheet
        FirstRow_book2 = 3
        LastRow_book2 = .Cells(.Rows.Count, "B").End(xlUp).Row

        'The contents of the tracking book
        FirstRow_book1 = 3
        LastRow_book1 = wbSheet.Cells(.Rows.Count, "A").End(xlUp).Row

        For Lrow = LastRow_book2 To FirstRow_book2 Step -1
            With .Cells(Lrow, "B")
                 Pupid = .Value
            End With

            'The For Loop Now Iterates Through All of the First WorkBook
            For Lrow_book1 = LastRow_book1 To FirstRow_book1 Step -1
                With wbSheet.Cells(Lrow_book1, "A")
                    If .Value = Pupid Then

                        'Reference for Date Changed Cells
                         wbSheet.Cells(Lrow_book1, "V") = wb2sheet.Cells(Lrow, "C")

                        'Reference for Date Changed Cells
                         wbSheet.Cells(Lrow_book1, "X") = wb2sheet.Cells(Lrow, "D")

                         'Prepare to copy range of multiple columns
                        Let secondBookRange = "I" & Lrow & ":" & "N" & Lrow
                        Let firstBookRange = "AI" & Lrow_book1 & ":" & "AN" & Lrow_book1

                        wb2sheet.Range(secondBookRange).Copy Destination:=wbSheet.Range(firstBookRange)


                    End If
                End With
            Next Lrow_book1
        Next Lrow
    End With

Current Implementation using a Dictionary/Hash Map:

Sub CopyLinesImproves()
    Dim vFile As Variant
    Dim Filter As String
    Dim FilterIndex As Integer
    Dim Pupid As Long

    'Set Tracking Book
    Set wb_TrackingBook = ActiveWorkbook
    Set wbSheet_TrackingBook = ActiveSheet

    'Set Last Row of TrackingBook
    LastRow_TrackingBook = wbSheet_TrackingBook.Cells(wbSheet_TrackingBook.Rows.Count, "A").End(xlUp).Row

    'Filters for allowed files
    Filter = "Excel Later Versions (*.xlsx),*.xlsx," & _
             "Excel Files (*.xls),*.xls,"

    FilterIndex = 1

    'Open the target workbook
    vFile = Application.GetOpenFilename(Filter, FilterIndex, "Select One File to Open", , False)

    'if the user didn't select a file, exit sub
    If TypeName(vFile) = "Boolean" Then Exit Sub

    'Else open the file
    Set wb_NewData = Workbooks.Open(vFile)
    Set wbSheet_NewData = wb_NewData.ActiveSheet

    'Set First Row and Last Row of the New Data Worksheet
    FirstRow_NewData = 3
    LastRow_NewData = wbSheet_NewData.Cells(wbSheet_NewData.Rows.Count, "B").End(xlUp).Row

    'create a lookup map using a dictionary
    Set rngLookup = wbSheet_TrackingBook.Range("A1").Resize(LastRow_TrackingBook, 1)
    Set d = GetMap(rngLookup)


    For CurrentRow = FirstRow_NewData To LastRow_NewData Step 1
        Pupid = wbSheet_NewData.Cells(CurrentRow, "B").Value
        If d.exists(Pupid) Then

            wbSheet_TrackingBook.Cells(d(Pupid), "V") = wbSheet_NewData.Cells(CurrentRow, "C")
            wbSheet_TrackingBook.Cells(d(Pupid), "X") = wbSheet_NewData.Cells(CurrentRow, "D")


            Let secondBookRange = "I" & CurrentRow & ":" & "N" & CurrentRow
            Let firstBookRange = "AI" & d(Pupid) & ":" & "AN" & d(Pupid)

            wbSheet_NewData.Range(secondBookRange).Copy Destination:=wbSheet_TrackingBook.Range(firstBookRange)

        End If
    Next CurrentRow

End Sub
Function GetMap(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 GetMap = d
End Function

Answer 1

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