Excel VBA-通过一个工作簿中的列迭代，将信息粘贴到相应的工作簿中 [英] Excel VBA- Iterate through columns in one workbook, pasting information in corresponding workbook
本文介绍了Excel VBA-通过一个工作簿中的列迭代，将信息粘贴到相应的工作簿中的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
对于最近数据的B列中的每个ID，通过
迭代所有行在存档的工作簿的A列。如果有
匹配，则将近期数据工作簿的各个列条目复制到存档工作簿
中。
我写了工作代码，但问题是，在归档数据工作簿中有1,048,575行，所以For循环对于每个匹配运行得非常慢。有没有更好的方法来考虑这个问题？
这是我现在的代码：
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
'设置源工作簿
设置wb = ActiveWorkbook
设置wbSheet = ActiveSheet
'过滤器允许的文件
Filter =Excel以后的版本（* .xlsx），*。xlsx，& _
Excel文件（* .xls），*。xls，
FilterIndex = 1
'打开目标工作簿
vFile =应用程序.GetOpenFilename（Filter，FilterIndex，Select One File to Open，，False）
'如果用户未选择文件，则退出sub
如果TypeName（vFile）=然后退出Sub
'否则打开文件
Workbooks.Open vFile
'设置要从
复制的工作簿设置wb2 = ActiveWorkbook
设置wb2sheet = ActiveSheet
带有wb2.ActiveSheet
FirstRow_book2 = 3
LastRow_book2 = .Cells（.Rows.Count，B）。End（xlUp）.Row
'跟踪书的内容
FirstRow_book1 = 3
LastRow_book1 = wbSheet.Cells（.Rows.Count，A）。End（xlUp）.Row
对于Lrow = LastRow_book2 To FirstRow_book2步骤-1
带.Cells（Lrow，B）
Pupid = .Value
结束
'For循环现在迭代所有的第一个工作簿
对于Lrow_book1 = LastRow_book1 To FirstRow_book1步骤-1
与wbSheet.Cells（Lrow_book1，A）
如果。值= Pupid然后
'参考日期更改单元格
wbSheet.Cells（Lrow_book1，V）= wb2sheet.Cells（Lrow，C）
'参考日期更改单元格
wbSheet.Cells（Lrow_book1，X）= wb2sheet.Cells（Lrow，D）
'准备复制多个列的范围
让secondBookRange =I& Lrow& ：& N& Lrow
让firstBookRange =AI& Lrow_book1& ：& AN& Lrow_book1
wb2sheet.Range（secondBookRange）.Copy目的地：= wbSheet.Range（firstBookRange）
如果
结束
Next Lrow_book1
Next Lrow
结束
使用字典/哈希的当前实现地图：
Sub CopyLinesImproves（）
Dim vFile As Variant
Dim Filter As String
Dim FilterIndex As Integer
Dim Pupid As Long
'设置跟踪书
设置wb_TrackingBook = ActiveWorkbook
设置wbSheet_TrackingBook = ActiveSheet
'设置最后一行TrackingBook
LastRow_TrackingBook = wbSheet_TrackingBook.Cells（wbSheet_TrackingBook.Rows.Count，A）。End（xlUp）.Row
'过滤器允许的文件
Filter = Excel以后版本（* .xlsx），*。xlsx，& _
Excel文件（* .xls），*。xls，
FilterIndex = 1
'打开目标工作簿
vFile =应用程序.GetOpenFilename（Filter，FilterIndex，Select One File to Open，，False）
'如果用户未选择文件，则退出sub
如果TypeName（vFile）=然后退出Sub
'否则打开文件
设置wb_NewData = Workbooks.Open（vFile）
设置wbSheet_NewData = wb_NewData.ActiveSheet
'设置新数据工作表的第一行和最后一行
FirstRow_NewData = 3
LastRow_NewData = wbSheet_NewData.Cells（wbSheet_NewData.Rows.Count，B）。End（xlUp）.Row
'使用字典创建查找地图
设置rngLookup = wbSheet_TrackingBook.Range（A1）。调整大小（LastRow_TrackingBook，1）
设置d = GetMap（rngLookup）
对于CurrentRow = FirstRow_NewData To LastRow_NewData步骤1
Pupid = wbSheet_NewData.Cells（CurrentRow，B） .Value
如果d.exists（Pupid）然后
wbSheet_TrackingBook.Cells（d（Pupid），V）= wbSheet_NewData.Cells（CurrentRow，C）
wbSheet_TrackingBook.Cells（d（Pupid），X）= wbSheet_NewData.Cells（CurrentRow，D）
让secondBookRange =I& CurrentRow& ：& N& CurrentRow
让firstBookRange =AI& d（Pupid）& ：& AN& d（Pupid）
wbSheet_NewData.Range（secondBookRange）.Copy目的地：= wbSheet_TrackingBook.Range（firstBookRange）
结束如果
下一个CurrentRow
End Sub
函数GetMap（rng）As Object
Dim d，v，arr，ub As Long，r As Long，r1 As Long
Dim c As Range
设置d = CreateObject（scripting.dictionary）
arr = rng.Value
r1 = rng.Cells（1）.Row
ub = UBound（arr，1）
对于r = 1到ub
v = arr（r，1）
如果Len（v）> 0然后
如果d.exists（v）然后
d（v）= d（v）& | &安培; r1 +（r-1）
Else
d.Add v，r1 +（r-1）
End If
End If
Next r
设置GetMap = d
结束函数
解决方案
运行通过循环单元格或使用 Find（）可以很大程度地重复查找大范围。根据正在搜索的行数以及您正在运行的查找次数（以及可以在查找范围内重复查找ID）还有一些其他选项，例如（例如）使用以下命令创建查找数据的映射字典或使用 MATCH（）。
下面是一些代码（下面）来说明一些不同的方法。我创建了一个包含1到1048535的随机数字的查找列，然后使用不同的方法在不同大小的范围上运行不同数量的查找。
运行100或100个价值范围的1000次查询：
编辑：添加收藏方式（谢谢Sid）
####搜索：100000＃查找：100
循环图：0查找：14.777总计：14.777
循环（数组）地图：0查找：0.711总计：0.711
查找地图：0查找：8.762总计：8.762
字典地图：0.73查询：0.00391总计：0.73391
收藏地图：0.723查询：0总计：0.723
匹配地图：0查找：0.145总计：0.145
####搜索：100000＃查询：1000
循环图：0查询：150.984总计：150.984
循环（数组）映射：0查询：6.465总计：6.465
查找地图：0查找：82.527总计：82.527
字典地图：0.602查询：0.00781总计：0.60981
收藏地图：0.672查询：0.00781总计：0.67981
匹配地图：0查找：1.359总计：1.359
基本循环通过单元格就地方法是测试方法中最慢的方法：您可以通过循环覆盖从查找范围中提取的数组来改进此方法> 10倍。
Find（）一直很慢（只是基本循环方法的两倍），大型查找也是超级慢。 Match（）为100次查找打开Dictionary / Collection方法，但是Dictonary和Collection方法对于更大数量的查找而言更好地缩放，因为映射开销仅依赖于查找范围的大小以及每个查找操作非常快。
代码：
Option Explicit
Sub SpeedTests（）
Const NUM_ROWS As Long = 100000
Const NUM_IDS As Long = 1000
Dim rngLookup As范围，f As范围
Dim d，d2，t，l As Long，v，t1，t2
Dim arr，c As Range，ub As Long，rw As Long
设置rngLookup = ActiveSheet.Range（A1）。调整大小（NUM_ROWS，1）
Debug.Print####搜索：& NUM_ROWS，＃lookups：& NUM_IDS
'基本循环
t =定时器
对于l = 1到NUM_IDS
对于每个c在rngLookup.Cells
如果c.Value = l然后
'found
End If
Next c
Next l
t2 = Round（Timer - t，3）
t1 = 0
调试.PrintLoop，Map：0，Lookup：& t2，Total：& （t1 + t2）
'循环在数组
t =定时器
arr = rngLookup.Value
t1 =回合（定时器 - t，3）
ub = UBound（arr，1）
对于l = 1到NUM_IDS
对于rw = 1到ub
如果arr（rw，1）= l然后
'找到
结束如果
下一个rw
下一个l
t2 = Round（Timer - t，3）
t1 = 0
Debug.PrintLoop（array） ，Map：0，Lookup：& t2，Total：& （t1 + t2）
'定期使用Find（）
t = Timer
对于l = 1到NUM_IDS
设置f = rngLookup.Find（l，LookIn ：= xlValues，lookat：= xlWhole）
如果不是f是没有，然后
v = f.Row
Else
v = 0
结束如果
下一个l
t2 = Round（Timer-t，3）
t1 = 0
Debug.PrintFind，Map：0，Lookup：& t2，Total：& （t1 + t2）
'使用字典创建查找地图
t = Timer
设置d = GetMapDict（rngLookup）
t1 = Round（Timer - t， 3）
t =定时器
对于l = 1到NUM_IDS
如果d.exists（l）然后
v = d（l）
Else
v = 0
End If
Next l
t2 = Round（Timer - t，5）
Debug.PrintDictionary，Map：& t1，Lookup：& t2，Total：& （t1 + t2）
设置d = Nothing
'使用集合创建一个查找映射
t = Timer
设置d2 = GetMapCollection（rngLookup）
t1 = Round（Timer-t，3）
t =定时器
错误恢复下一步
对于l = 1到NUM_IDS
d2.Add 0，CStr（l）
如果Err.Number<> 0然后
'找到！
Err.Clear
End If
Next l
t2 = Round（Timer - t，5）
Debug.PrintCollection，Map：& t1，Lookup：& t2，Total：& （t1 + t2）
设置d =没有
'使用Match（）
t1 = 0
t =定时器
对于l = 1到NUM_IDS
v = Application.Match（l，rngLookup，0）
如果IsError（v）则v = 0
Next l
t2 = Round（Timer - t，3 ）
Debug.PrintMatch，Map：& t1，Lookup：& t2，Total：& （t1 + t2）
End Sub
函数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）
对于r = 1 To ub
v = arr（r，1）
如果Len（v）> 0然后
On Error Resume Next
d.Add r1 +（r-1），CStr（v）
On Error GoTo 0
End If
Next r
设置GetMapCollection = d
结束函数
函数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）
对于r = 1到ub
v = arr（r，1）
如果Len（v）> 0然后
如果d.exists（v）然后
d（v）= d（v）& | &安培; r1 +（r-1）
Else
d.Add v，r1 +（r-1）
End If
End If
Next r
设置GetMapDict = d
结束函数
I have current data in one workbook and archived data in another workbook. In column "B" of Recent Data Workbook I have an ID variable. I want to say:
For each of the IDs in Column B of the Recent Data, Iterate through all of the rows in Column A of the Archived Workbook. If there is a match, than copy various column entries of Recent Data Workbook into the Archived Workbook.
I wrote working code, but the problem is that, in the Archived Data workbook there is 1,048,575 rows and so the For loops run extremely slowly for each 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 a 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
解决方案
Running repeated lookups on a large range by looping through the cells or using Find() can be very slow. Depending on how many rows are being searched and how many lookups you're running (and whether ID's can be repeated in the lookup range) there are a few other options such as (eg) creating a "map" of the lookup data using a Dictionary, or using MATCH().
Here's some code (below) to illustrate some different methods. I created a lookup column containing randomized numbers from 1 to 1048535 and then used different methods to run varying numbers of lookups on different-sized ranges.
Sample output when running 100 or 1000 lookups on a 100k-value range:
EDIT: added collection method (thanks 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
The basic "loop through the cells in-place" approach is the slowest of the methods tested: you can improve this approach >10-fold by instead looping over an array extracted from the lookup range.
Find() is consistently slow (only about twice as fast as the basic loop approach) and for large lookups is super-slow. Match() beats the Dictionary/Collection approaches for 100 lookups, but the Dictonary and Collection approaches scale better for larger numbers of lookups, since the "map" overhead is dependent only on the size of the lookup range, and each "lookup" operation is very fast..
Code:
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
这篇关于Excel VBA-通过一个工作簿中的列迭代，将信息粘贴到相应的工作簿中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
