我将当前数据放在一个工作簿中，将归档数据放在另一个工作簿中。在最近数据工作簿的“B”列中，我有一个ID变量。我想说：
对于最近数据的B列中的每个ID，迭代 存档工作簿的A列中的所有行。如果有的话 匹配，而不是将最近数据工作簿的各个列条目复制到 存档工作簿。
我编写了工作代码，但问题是，在Archived Data工作簿中有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
答案 0 :(得分：9)
通过循环遍历单元格或使用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方法可以更好地扩展到大量查找，因为“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