Geek Answers Handbook

Excel VBA- Iterate through columns in a single workbook, insert information into the corresponding workbook

I have current data in one book and archive data in another book. In column "B" in the book "New Data" I have an identifier variable. I want to say:

For each of the identifiers in column B of the latest data, iterates through all the rows in column A of the archive book. If there is a comparison, than copy the various column entries in the recent data book to the Archived Workbook.

I wrote working code, but the problem is that the Archived Data book has 1,048,575 lines, and therefore For loops work very slowly for every 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 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
+4
1

Find() . , ( ID ) , () "" , MATCH().

(), . , 1 1048535, .

100 1000 100 . :

EDIT: ( 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

"loop through the cells in-place" : > 10 , , .

Find() ( , ), - -. MATCH() "/" 100 , Dictonary Collection , "" ..

:

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
+9

More articles:


All Articles