.Find VBA 跨两个工作表执行需要很长时间
.Find VBA taking a long time to execute across two worksheets
我正在使用 VBA 循环遍历两个工作 sheet 上的行，如果它们匹配，则将行从 sheet 2 复制到 sheet 1。
我的代码应该：
- 打开第二个工作簿
- 将所有信息复制到新 sheet
的原始工作簿中
- 然后循环遍历原始 Sheet（450+ 行）上的 F 列，并在新“数据”sheet（9,500+ 行）上找到活动单元格，找到相同的值后复制整行并将其粘贴到原始 sheet 然后循环再次开始。
虽然这确实有效，但我发现这需要超过 20 分钟，这太长了！我是 VBA 的初学者，虽然我取得了很好的进步，但我仍然坚持这一点，我已经阅读了变体，但老实说，它们让我感到困惑！任何帮助将不胜感激:)
Sub AutoUpdate()
'Opens Enterprise Master Lead File (whichever is present) and auto updates data
' in current sheet depending on if ID ref is present
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'This opens the workbook without setting set date as long as the
'file is always in the same place
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim rng As Range, Cel As Range
Dim sFind As String
Dim lastRow As Long
lastRow = Range("F" & Rows.Count).End(xlUp).Row
Set rng = Range("F2:F" & lastRow)
Set Wb = ThisWorkbook
Set Wb2 = Workbooks.Open("xxxxxxxxxxx.xlsx") 'opens secondary workbook
'Deletes unecessary columns
Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD").Select
Selection.Delete Shift:=xlToLeft
Range("A2").Select
Cells.Select
Selection.Copy
Wb.Activate
Sheets.Add.Name = "Data"
Range("A1").Select
ActiveSheet.Paste
Wb2.Close 'closes secondary workbook to speed up process
Wb.Activate
'Loop - finds data in original sheet, finds data in secondary
'sheet, copies new data and pastes, offsets and starts again
Sheets("Corp Leads").Activate
With Wb
rng.Select
'Range("F1").Select
'ActiveCell.Offset(1, 0).Select
'Range(Selection, Selection.End(xlDown)).Select
For Each Cel In rng
If Cel.Value > 0 Then
ActiveCell.Select
sFind = ActiveCell
'Finding matching data
Sheets("Data").Activate
Range("F2").Select
Range(Selection, Selection.End(xlDown)).Select
Cells.Find(What:=sFind, After:= _
ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Select
'copying new data row
ActiveCell.EntireRow.Select
Selection.Copy
'Finding same data again in original sheet
Sheets("Corp Leads").Activate
Cells.Find(What:=sFind, After:= _
ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Select
'Pasting new data
ActiveCell.EntireRow.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Finding reference again to offset for loop
Cells.Find(What:=sFind, After:= _
ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Select
ActiveCell.Offset(1, 0).Select
End If
Next Cel
End With
Sheets("Data").Delete
MsgBox ("UPDATED")
End Sub
正如我在评论中提到的，并不是 .Find 花费了这么长时间。使用 .Select/.Activate 等会减慢您的代码速度。你可能想看看 How to avoid using Select in Excel VBA
此代码为非数组版本。看看我是如何避免使用 .Select/.Activate?
Option Explicit
Sub Sample()
Dim wbThis As Workbook: Set wbThis = ThisWorkbook
Dim wbThat As Workbook
'~~> Change this to the relevant worksheet
Dim wsThis As Worksheet: Set wsThis = wbThis.Sheets("Corp Leads")
Dim wsNewThis As Worksheet
Dim wsThat As Worksheet
'~~> Add the data sheet if required
On Error Resume Next
Set wsNewThis = wbThis.Sheets("Data")
On Error GoTo 0
If wsNewThis Is Nothing Then
wbThis.Sheets.Add.Name = "Data"
Else
wsNewThis.Cells.Clear
End If
'~~> Open the relvant workbook
Set wbThat = Workbooks.Open("xxxxxxxxxxx.xlsx")
Set wsThat = wbThat.Sheets("RelevantSheetName")
Dim lastRow As Long
Dim lastCol As Long
With wsThat
.Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD").Delete
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lastCol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
lastRow = 1: lastCol = 1
End If
.Range(.Cells(1, 1), .Cells(lastRow, lastCol)).Copy wsNewThis.Range("A1")
DoEvents
.Close (False)
End With
Dim aCell As Range
With wsThis
lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
For i = lastRow To 2 Step -1
If .Range("F" & i).Value2 > 0 Then
Set aCell = wsNewThis.Columns(6).Find(What:=.Range("F" & i).Value2, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
.Rows(i + 1).Insert
wsNewThis.Rows(aCell.Row).Copy .Rows(i + 1)
End If
End If
Next i
End With
Application.DisplayAlerts = False
wsNewThis.Delete
Application.DisplayAlerts = True
End Sub
因此，在 Siddharth（评论）的帮助下，我想出了一些有效的代码，并且在不到一分钟的时间内完成了查询，而不是一张而是两张单独的工作表，这就是整个任务！
仍在使用一些 .select 语句，我知道这些语句很顽皮，但它仍然表现得非常好。很高兴更新任何进一步的建议，发现今天参与评论非常有帮助！ :)
可能不是最简洁的代码，但它确实有效！
子更新()
Application.DisplayAlerts = 假
Application.ScreenUpdating = 假
Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim wb2 As Workbook
'~~> Change this to the relevant worksheet
Dim ws1 As Worksheet: Set ws1 = wb1.Sheets("Worksheet1")
Dim ws2 As Worksheet: Set ws2 = wb1.Sheets("Worksheet2")
Dim wsdata As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("xxxxxxxxxxxx*" & ".xlsx") 'opens secondary workbook
'Deletes unecessary columns
Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD"). _
Select
Selection.Delete Shift:=xlToLeft
Range("A2").Select
Cells.Select
Selection.Copy
wb1.Activate
Sheets.Add.Name = "Data"
Range("A1").Select
ActiveSheet.Paste
wb2.Close 'closes secondary workbook to speed up process
wb1.Activate
Dim aCell As Range
Dim i As Long
Set wsdata = wb1.Sheets("Data")
'Finds matching values (externel ref ID) using Corp Leads and Data sheets
With ws1
lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
For i = lastRow To 2 Step -1
If .Range("F" & i).Value2 > 0 Then
Set aCell = wsdata.Columns(6).Find(What:=.Range("F" & i).Value2, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'inserts updated rows into corp leads sheet
If Not aCell Is Nothing Then
wsdata.Rows(aCell.Row).Copy .Rows(i)
End If
End If
Next i
End With
With ws2
lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
For i = lastRow To 2 Step -1
If .Range("F" & i).Value2 > 0 Then
Set aCell = wsdata.Columns(6).Find(What:=.Range("F" & i).Value2, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
wsdata.Rows(aCell.Row).Copy .Rows(i)
End If
End If
Next i
End With
wsdata.Delete
Application.DisplayAlerts = True
MsgBox "UPDATED"
End Sub
这是一个使用数组和字典查找的版本，它比使用 Find()
的循环更快
Sub Update()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws
Dim wsdata As Worksheet, wsImport As Worksheet
Dim dict As Object, k, i As Long, m, arrF
'~~> Change this to the relevant worksheet
Set wb1 = ThisWorkbook
Set ws1 = wb1.Sheets("Worksheet1")
Set ws2 = wb1.Sheets("Worksheet2")
On Error GoTo haveError
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wb2 = Workbooks.Open("xxxxxxxxxxxx*" & ".xlsx") 'opens secondary workbook
Set wsdata = wb2.Sheets(1) 'for example, or use name if known
wsdata.Range("C:D,G:K,M:Q,S:S,U:W,Z:Z,AD:AD").Delete 'Delete unecessary columns
'create a lookup on ColF in data source and map to row number
Set dict = CreateObject("scripting.dictionary")
' get data into an array (1 to #rows, 1 to #cols)
arrF = wsdata.Range("F1:F" & wsdata.Cells(Rows.Count, "F").End(xlUp).Row).Value
For i = 2 To UBound(arrF) 'loop over the array; exclude header
dict(arrF(i, 1)) = i 'maps row number to value
Next i
For Each ws In Array(ws1, ws2) 'update each sheet in turn
arrF = ws.Range("F1:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row).Value
For i = 2 To UBound(arrF) 'exclude header
k = arrF(i, 1)
If k > 0 Then
If dict.exists(k) Then
ws.Rows(i).Value = wsdata.Rows(dict(k)).Value 'faster
'wsdata.Rows(dict(k)).Copy ws.Cells(i, 1)
End If
End If
Next i
Next ws
'wb2.Close False 'don't save changes
MsgBox "UPDATED"
haveError:
Application.Calculation = xlCalculationAutomatic
End Sub
我正在使用 VBA 循环遍历两个工作 sheet 上的行，如果它们匹配，则将行从 sheet 2 复制到 sheet 1。
我的代码应该：
- 打开第二个工作簿
- 将所有信息复制到新 sheet 的原始工作簿中
- 然后循环遍历原始 Sheet（450+ 行）上的 F 列，并在新“数据”sheet（9,500+ 行）上找到活动单元格，找到相同的值后复制整行并将其粘贴到原始 sheet 然后循环再次开始。
虽然这确实有效，但我发现这需要超过 20 分钟，这太长了！我是 VBA 的初学者，虽然我取得了很好的进步，但我仍然坚持这一点，我已经阅读了变体，但老实说，它们让我感到困惑！任何帮助将不胜感激:)
Sub AutoUpdate()
'Opens Enterprise Master Lead File (whichever is present) and auto updates data
' in current sheet depending on if ID ref is present
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'This opens the workbook without setting set date as long as the
'file is always in the same place
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim rng As Range, Cel As Range
Dim sFind As String
Dim lastRow As Long
lastRow = Range("F" & Rows.Count).End(xlUp).Row
Set rng = Range("F2:F" & lastRow)
Set Wb = ThisWorkbook
Set Wb2 = Workbooks.Open("xxxxxxxxxxx.xlsx") 'opens secondary workbook
'Deletes unecessary columns
Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD").Select
Selection.Delete Shift:=xlToLeft
Range("A2").Select
Cells.Select
Selection.Copy
Wb.Activate
Sheets.Add.Name = "Data"
Range("A1").Select
ActiveSheet.Paste
Wb2.Close 'closes secondary workbook to speed up process
Wb.Activate
'Loop - finds data in original sheet, finds data in secondary
'sheet, copies new data and pastes, offsets and starts again
Sheets("Corp Leads").Activate
With Wb
rng.Select
'Range("F1").Select
'ActiveCell.Offset(1, 0).Select
'Range(Selection, Selection.End(xlDown)).Select
For Each Cel In rng
If Cel.Value > 0 Then
ActiveCell.Select
sFind = ActiveCell
'Finding matching data
Sheets("Data").Activate
Range("F2").Select
Range(Selection, Selection.End(xlDown)).Select
Cells.Find(What:=sFind, After:= _
ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Select
'copying new data row
ActiveCell.EntireRow.Select
Selection.Copy
'Finding same data again in original sheet
Sheets("Corp Leads").Activate
Cells.Find(What:=sFind, After:= _
ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Select
'Pasting new data
ActiveCell.EntireRow.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Finding reference again to offset for loop
Cells.Find(What:=sFind, After:= _
ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Select
ActiveCell.Offset(1, 0).Select
End If
Next Cel
End With
Sheets("Data").Delete
MsgBox ("UPDATED")
End Sub
正如我在评论中提到的，并不是 .Find 花费了这么长时间。使用 .Select/.Activate 等会减慢您的代码速度。你可能想看看 How to avoid using Select in Excel VBA
此代码为非数组版本。看看我是如何避免使用 .Select/.Activate?
Option Explicit
Sub Sample()
Dim wbThis As Workbook: Set wbThis = ThisWorkbook
Dim wbThat As Workbook
'~~> Change this to the relevant worksheet
Dim wsThis As Worksheet: Set wsThis = wbThis.Sheets("Corp Leads")
Dim wsNewThis As Worksheet
Dim wsThat As Worksheet
'~~> Add the data sheet if required
On Error Resume Next
Set wsNewThis = wbThis.Sheets("Data")
On Error GoTo 0
If wsNewThis Is Nothing Then
wbThis.Sheets.Add.Name = "Data"
Else
wsNewThis.Cells.Clear
End If
'~~> Open the relvant workbook
Set wbThat = Workbooks.Open("xxxxxxxxxxx.xlsx")
Set wsThat = wbThat.Sheets("RelevantSheetName")
Dim lastRow As Long
Dim lastCol As Long
With wsThat
.Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD").Delete
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lastCol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
lastRow = 1: lastCol = 1
End If
.Range(.Cells(1, 1), .Cells(lastRow, lastCol)).Copy wsNewThis.Range("A1")
DoEvents
.Close (False)
End With
Dim aCell As Range
With wsThis
lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
For i = lastRow To 2 Step -1
If .Range("F" & i).Value2 > 0 Then
Set aCell = wsNewThis.Columns(6).Find(What:=.Range("F" & i).Value2, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
.Rows(i + 1).Insert
wsNewThis.Rows(aCell.Row).Copy .Rows(i + 1)
End If
End If
Next i
End With
Application.DisplayAlerts = False
wsNewThis.Delete
Application.DisplayAlerts = True
End Sub
因此，在 Siddharth（评论）的帮助下，我想出了一些有效的代码，并且在不到一分钟的时间内完成了查询，而不是一张而是两张单独的工作表，这就是整个任务！
仍在使用一些 .select 语句，我知道这些语句很顽皮，但它仍然表现得非常好。很高兴更新任何进一步的建议，发现今天参与评论非常有帮助！ :)
可能不是最简洁的代码，但它确实有效！
子更新()
Application.DisplayAlerts = 假 Application.ScreenUpdating = 假
Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim wb2 As Workbook
'~~> Change this to the relevant worksheet
Dim ws1 As Worksheet: Set ws1 = wb1.Sheets("Worksheet1")
Dim ws2 As Worksheet: Set ws2 = wb1.Sheets("Worksheet2")
Dim wsdata As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("xxxxxxxxxxxx*" & ".xlsx") 'opens secondary workbook
'Deletes unecessary columns
Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD"). _
Select
Selection.Delete Shift:=xlToLeft
Range("A2").Select
Cells.Select
Selection.Copy
wb1.Activate
Sheets.Add.Name = "Data"
Range("A1").Select
ActiveSheet.Paste
wb2.Close 'closes secondary workbook to speed up process
wb1.Activate
Dim aCell As Range
Dim i As Long
Set wsdata = wb1.Sheets("Data")
'Finds matching values (externel ref ID) using Corp Leads and Data sheets
With ws1
lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
For i = lastRow To 2 Step -1
If .Range("F" & i).Value2 > 0 Then
Set aCell = wsdata.Columns(6).Find(What:=.Range("F" & i).Value2, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'inserts updated rows into corp leads sheet
If Not aCell Is Nothing Then
wsdata.Rows(aCell.Row).Copy .Rows(i)
End If
End If
Next i
End With
With ws2
lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
For i = lastRow To 2 Step -1
If .Range("F" & i).Value2 > 0 Then
Set aCell = wsdata.Columns(6).Find(What:=.Range("F" & i).Value2, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
wsdata.Rows(aCell.Row).Copy .Rows(i)
End If
End If
Next i
End With
wsdata.Delete
Application.DisplayAlerts = True
MsgBox "UPDATED"
End Sub
这是一个使用数组和字典查找的版本，它比使用 Find()
Sub Update()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws
Dim wsdata As Worksheet, wsImport As Worksheet
Dim dict As Object, k, i As Long, m, arrF
'~~> Change this to the relevant worksheet
Set wb1 = ThisWorkbook
Set ws1 = wb1.Sheets("Worksheet1")
Set ws2 = wb1.Sheets("Worksheet2")
On Error GoTo haveError
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wb2 = Workbooks.Open("xxxxxxxxxxxx*" & ".xlsx") 'opens secondary workbook
Set wsdata = wb2.Sheets(1) 'for example, or use name if known
wsdata.Range("C:D,G:K,M:Q,S:S,U:W,Z:Z,AD:AD").Delete 'Delete unecessary columns
'create a lookup on ColF in data source and map to row number
Set dict = CreateObject("scripting.dictionary")
' get data into an array (1 to #rows, 1 to #cols)
arrF = wsdata.Range("F1:F" & wsdata.Cells(Rows.Count, "F").End(xlUp).Row).Value
For i = 2 To UBound(arrF) 'loop over the array; exclude header
dict(arrF(i, 1)) = i 'maps row number to value
Next i
For Each ws In Array(ws1, ws2) 'update each sheet in turn
arrF = ws.Range("F1:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row).Value
For i = 2 To UBound(arrF) 'exclude header
k = arrF(i, 1)
If k > 0 Then
If dict.exists(k) Then
ws.Rows(i).Value = wsdata.Rows(dict(k)).Value 'faster
'wsdata.Rows(dict(k)).Copy ws.Cells(i, 1)
End If
End If
Next i
Next ws
'wb2.Close False 'don't save changes
MsgBox "UPDATED"
haveError:
Application.Calculation = xlCalculationAutomatic
End Sub