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 

當前使用字典/哈希的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

通過細胞循環或者使用Find()可以運行在一個大的區間內反覆查找非常慢。取決於正在搜索的行數以及您正在運行的查找數量（以及是否可以在查找範圍內重複查找ID），還有其他幾個選項，例如（例如）使用a創建查找數據的「映射」字典，或使用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次查找的字典/收集方法，但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