Excel VBA – 遍历一个工作簿中的列，将信息粘贴到相应的工作簿中
我有一个工作簿中的当前数据和另一个工作簿中的存档数据。 在“最近数据工作簿”的“B”列中，我有一个IDvariables。 我想说：
对于最近数据的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
通过循环遍历单元或使用Find()在大范围内运行重复查找可能非常缓慢。 取决于正在search的行数以及您正在运行的查找数量（以及ID是否可以在查找范围内重复），还有其他几个选项，例如（例如）使用一个查询数据创build查找数据的“映射”字典或使用MATCH() 。
这里有一些代码（下面）来说明一些不同的方法。 我创build了一个包含从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
基本的“循环通过细胞就地”方法是testing方法中最慢的方法：通过循环遍历从查找范围提取的数组，可以将这种方法改进10倍以上。
Find()一直很慢（大约是基本循环方法的两倍），而大型查找则超慢。 Match()在100次查找方面击败了Dictionary / Collection方法，但Dictonary和Collection方法对于大量的查找来说比较好，因为“map”开销仅取决于查找范围的大小，而每个“查找”操作非常快
码：
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