大家好，我對 VBA 詞很陌生，順便說一句，當兩張表的第一列中的字串匹配時，我寫了一些代碼來將一些行從一個作業表復制到另一個作業表。問題是我在 a = 16 行和 j = 15000 行上回圈，所以代碼真的很慢。我使用 j = 1000 進行了測驗，以使參考時間等于 20 秒。
您對加快代碼速度有什么建議嗎？泰。
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws = Worksheets("Calcoli")
Set ws2 = Worksheets("Anagrafica")
Dim a As Long
Dim j As Long
Last_calcoli = ws.Cells(Rows.Count, 1).End(xlUp).Row
Last_anagrafica = ws2.Cells(Rows.Count, 1).End(xlUp).Row
T0 = Timer
ScreenUpdateState = Application.ScreenUpdating
StatusBarState = Application.DisplayStatusBar
CalcState = Application.Calculation
EventsState = Application.EnableEvents
DisplayPageBreakState = ActiveSheet.DisplayPageBreaks
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
For a = 2 To Last_anagrafica
MyString2 = Worksheets("Anagrafica").Cells(a, 1)
For j = 2 To 1000 'in faster version update 1000 to Last_calcoli
Compare2 = Worksheets("Calcoli").Cells(j, 1)
If MyString2 = Compare2 Then
ws2.Range("B" & a & ":D" & a).Copy 'original range
ws.Range("W" & j & ":Y" & j).PasteSpecial 'destination range
End If
Next j
Next a
Application.ScreenUpdating = ScreenUpdateState
Application.DisplayStatusBar = StatusBarState
Application.Calculation = CalcState
Application.EnableEvents = EventsState
ActiveSheet.DisplayPageBreaks = DisplayPageBreaksState
InputBox "The runtime of this program is", "Runtime", Timer - T0
End Sub
uj5u.com熱心網友回復：
Excel VBA 性能建議：
- 將資料加載到陣列中，而不是在范圍內的單元格上進行雙回圈迭代。
- 將
Anagrafica資料放入字典以加快比較速度，然后使用它來更新Calcoli資料。 - 最后一次輸出所有結果，而不是像遇到的那樣一次輸出一個。
這是考慮到這些內容的代碼重構。我添加了注釋以幫助提高可讀性：
Sub tgr()
'Start timer
Dim dTimer As Double: dTimer = Timer
On Error GoTo CleanExit 'If error is encountered anywhere, cleanly exit the sub and re-enable appstates
'Declare and set workbook, worksheet, and range variables
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim wsCal As Worksheet: Set wsCal = wb.Worksheets("Calcoli")
Dim rCal As Range: Set rCal = wsCal.Range("A2", wsCal.Cells(wsCal.Rows.Count, "A").End(xlUp))
Dim wsAna As Worksheet: Set wsAna = wb.Worksheets("Anagrafica")
Dim rAna As Range: Set rAna = wsAna.Range("A2", wsAna.Cells(wsAna.Rows.Count, "A").End(xlUp))
If rCal.Row < 2 Or rAna.Row < 2 Then Exit Sub 'No data
DisableAppStates 'Disable app states
'Declare and assign array variables (much faster to work on arrays rathern than ranges, but populate the arrays from your ranges)
Dim aCalID() As Variant: aCalID = rCal.Value
Dim aCalData() As Variant: aCalData = Intersect(rCal.EntireRow, wsCal.Columns("W:Y")).Value
Dim aAnaData() As Variant: aAnaData = rAna.Resize(, 4).Value
'Declare and prep a Dictionary object variable
'The dictionary will be used to perform lookup comparisons quickly to find matches
Dim hAna As Object: Set hAna = CreateObject("Scripting.Dictionary")
Dim aTemp() As Variant
Dim sAnaID As String, sCalID As String
Dim i As Long, j As Long
'Loop through your AnaData to populate the dictionary
For i = 1 To UBound(aAnaData, 1)
sAnaID = LCase(aAnaData(i, 1))
If Not hAna.Exists(sAnaID) Then
ReDim aTemp(1 To UBound(aAnaData, 2) - 1)
For j = 1 To UBound(aTemp)
aTemp(j) = aAnaData(i, j 1)
Next j
hAna.Add sAnaID, aTemp
Erase aTemp
Else
ReDim aTemp(1 To UBound(aAnaData, 2) - 1)
For j = 1 To UBound(aTemp)
aTemp(j) = aAnaData(i, j 1)
Next j
hAna(sAnaID) = aTemp
Erase aTemp
End If
Next i
'Dictionary has now been populated
'Loop through your CalData and use the dictionary to perform fast lookups
Dim bUpdate As Boolean: bUpdate = False
For i = 1 To UBound(aCalID, 1)
sCalID = LCase(aCalID(i, 1))
If hAna.Exists(sCalID) Then
'Matching IDs (values in column A of both sheets) found, update Cal Data columns
bUpdate = True
For j = 1 To UBound(aCalData, 2)
aCalData(i, j) = hAna(sCalID)(j)
Next j
End If
Next i
'If any updates are necessary, output the results with the updated data
If bUpdate Then wsCal.Range("W2").Resize(UBound(aCalData, 1), UBound(aCalData, 2)).Value = aCalData
'If any errors in the code were encountered, skip to here to ensure that app states get re-enabled
CleanExit:
EnableAppStates
MsgBox "The runtime of this program is " & Timer - dTimer & " seconds.", , "Runtime"
End Sub
Sub DisableAppStates()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.DisplayStatusBar = False
.Calculation = xlCalculationManual
End With
End Sub
Sub EnableAppStates()
With Application
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/shujuku/492095.html