vba - Excel VBA-遍历一个工作簿中的列，将信息粘贴到相应的工作簿中

Question

我在一个工作簿中有当前数据，在另一个工作簿中有存档数据。在最近数据工作簿的“B”列中，我有一个 ID 变量。我想说：

对于最近数据的 B 列中的每个 ID，遍历存档工作簿的 A 列中的所有行。如果匹配，则将最近数据工作簿的各个列条目复制到存档工作簿中。

我编写了工作代码，但问题是，在存档数据工作簿中有 1,048,575 行，因此每次匹配的 For 循环运行非常缓慢。有没有更好的方法来思考这个问题？

这是我当前的代码：

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

当前使用字典/哈希映射的实现：

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

通过循环遍历单元格或使用在大范围内重复查找Find()可能会非常慢。根据正在搜索的行数和正在运行的查找次数（以及 ID 是否可以在查找范围内重复），还有一些其他选项，例如（例如）使用字典，或使用MATCH().

这是一些代码（如下）来说明一些不同的方法。我创建了一个查找列，其中包含从 1 到 1048535 的随机数，然后使用不同的方法在不同大小的范围内运行不同数量的查找。

在 100k 值范围内运行 100 或 1000 次查找时的示例输出：

编辑：添加收集方法（感谢 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

基本的“就地循环遍历单元格”方法是测试方法中最慢的：您可以通过循环遍历从查找范围中提取的数组来改进这种方法 > 10 倍。

Find()一直很慢（只有基本循环方法的两倍左右）并且对于大型查找来说非常慢。Match()在 100 次查找中胜过 Dictionary/Collection 方法，但对于大量查找，Dictionary 和 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