我目前有代码允许我查看工作表1和工作表2中具有匹配ID的行。当两个ID匹配时,工作表2信息将粘贴到具有相同ID的工作表1行。我的代码工作不到1,000行,当我测试它时,它会在一分钟内得到结果。
问题在于,当我尝试运行1,000,000行时,它会持续运行超过20分钟并且从那时起就永远不会停止运行。我希望任何人都可以帮助我对代码进行更改,以允许我进行循环并将信息从工作表2复制粘贴到工作表1中200,000行。
Sub Sample()
Dim tracker As Worksheet
Dim master As Worksheet
Dim cell As Range
Dim cellFound As Range
Dim OutPut As Long
Set tracker = Workbooks("test.xlsm").Sheets("Sheet1")
Set master = Workbooks("test.xlsm").Sheets("Sheet2")
Application.ScreenUpdating = False
For Each cell In master.Range("A2:A200000")
Set cellFound = tracker.Range("A5:A43000").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not cellFound Is Nothing Then
matching value
cellFound.Offset(ColumnOffset:=1).Value2 = cell.Offset(ColumnOffset:=2).Value2
Else
End If
Set cellFound = Nothing
Debug.Print cell.Address
Next
Application.ScreenUpdating = True
OutPut = MsgBox("Update over!", vbOKOnly, "Update Status")
End Sub
以上是我现在的代码。
答案 0 :(得分:6)
加入@ paulbica的建议,这对我来说只需几秒钟。
Sub Sample()
Dim rngTracker As Range
Dim rngMaster As Range
Dim arrT, arrM
Dim dict As Object, r As Long, tmp
With Workbooks("test.xlsm")
Set rngTracker = .Sheets("Tracker").Range("A2:B43000")
Set rngMaster = .Sheets("Master").Range("A2:C200000")
End With
'get values in arrays
arrT = rngTracker.Value
arrM = rngMaster.Value
'load the dictionary
Set dict = CreateObject("scripting.dictionary")
For r = 1 To UBound(arrT, 1)
dict(arrT(r, 1)) = r
Next r
'map between the two arrays using the dictionary
For r = 1 To UBound(arrM, 1)
tmp = arrM(r, 1)
If dict.exists(tmp) Then
arrT(dict(tmp), 2) = arrM(r, 3)
End If
Next r
rngTracker.Value = arrT
End Sub
答案 1 :(得分:2)
您可以使用Dictionary object的索引并使用其原生索引属性来执行lokup。我不确定在一个200K记录的数据集中将会有多好,在这些记录中会发生高失败报告并且您显示至少78%的失败率(匹配和更新43K记录的200K记录) )。
Sub Sample3()
Dim tracker As Worksheet, master As Worksheet
Dim OutPut As Long
Dim v As Long, p As Long, vMASTER As Variant, vTRACKER As Variant, dMASTER As Object
Set tracker = Workbooks("test.xlsm").Sheets("Sheet1")
Set master = Workbooks("test.xlsm").Sheets("Sheet2")
Set dMASTER = CreateObject("Scripting.Dictionary")
Debug.Print Timer
'Application.ScreenUpdating = False '<~~no real need to do this if working in memory
With tracker
vTRACKER = .Range(.Cells(5, 2), .Cells(Rows.Count, 1).End(xlUp)).Value2
End With
With master
vMASTER = .Range(.Cells(2, 1), .Cells(Rows.Count, 3).End(xlUp)).Value2
For v = LBound(vMASTER, 1) To UBound(vMASTER, 1)
If Not dMASTER.exists(vMASTER(v, 1)) Then _
dMASTER.Add Key:=vMASTER(v, 1), Item:=vMASTER(v, 3)
Next v
End With
For v = LBound(vTRACKER, 1) To UBound(vTRACKER, 1)
If dMASTER.exists(vTRACKER(v, 1)) Then _
vTRACKER(v, 2) = dMASTER.Item(vTRACKER(v, 1))
Next v
With ThisWorkbook.Sheets("Sheet1") 'tracker
.Cells(5, 1).Resize(UBound(vTRACKER, 1), 2) = vTRACKER
End With
'Application.ScreenUpdating = True '<~~no real need to do this if working in memory
Debug.Print Timer
OutPut = MsgBox("Update over!", vbOKOnly, "Update Status")
dMASTER.RemoveAll: Set dMASTER = Nothing
Set tracker = Nothing
Set master = Nothing
End Sub
一旦将两个范围镜像到变体数组中,就会创建一个字典,以便充分利用其索引属性进行识别。
以上显示主中的效率显着提高超过200K记录,而跟踪器中的43K记录显着增加。
不过,我确实使用了.XLSB;不是.XLSM。答案 2 :(得分:2)
使用ADODB也可能更快。
Dim filepath As String
Dim conn As New ADODB.Connection
Dim sql As String
filepath = "c:\path\to\excel\file\book.xlsx"
With conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=""" & filepath & """;" & _
"Extended Properties=""Excel 12.0;HDR=No"""
sql = _
"UPDATE [Sheet1$A2:B200000] AS master " & _
"INNER JOIN [Sheet2$] AS tracker ON master.F1 = tracker.F1 " & _
"SET master.F2 = tracker.F2"
.Execute sql
End With
这适用于Office 2007.Office 2010(我未在2013年测试过)有security measure that prevents updating Excel spreadsheets with an SQL statement。在这种情况下,您可以使用旧的Jet提供程序,该提供程序没有此安全措施。此提供商不支持.xlsx
,.xlsm
或.xlsb
个文件;只有.xls
。
With conn
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=""" & filepath & """;" & _
"Extended Properties=""Excel 8.0;HDR=No"""
或者,您可以将结果数据读入断开连接的记录集,并将记录集粘贴到原始工作表中:
Dim filepath As String
Dim conn As New ADODB.Connection
Dim sql As String
Dim rs As New ADODB.Recordset
filepath = "c:\path\to\excel\file\book.xlsx"
With conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=""" & filepath & """;" & _
"Extended Properties=""Excel 12.0;HDR=No"""
sql = _
"SELECT master.F1, IIF(tracker.F1 Is Not Null, tracker.F2, master.F2) " & _
"FROM [Sheet1$A2:B200000] AS master " & _
"LEFT JOIN [Sheet2$] AS tracker ON master.F1 = tracker.F1 "
rs.CursorLocation = adUseClient
rs.Open sql, conn, adOpenForwardOnly, adLockReadOnly
conn.Close
End With
Workbooks.Open(filepath).Sheets("Sheet1").Cells(2, 1).CopyFromRecordset rs
如果使用CopyFromRecordset,请记住,不能保证返回记录的顺序,如果除了A列和B列之外master
工作表中还有其他数据,则可能会出现问题。解决此问题,您也可以在记录集中包含其他列。或者,您可以使用ORDER BY
子句强制执行记录的顺序,并在开始之前对工作表中的数据进行排序。