为循环加速

Question

大家好!我很新的VBA字，顺便说一句，我写了一个小代码复制一些行从一个工作表到另一个当在两个表的第一列的字符串匹配。问题是我在a = 16行和j = 15000行上循环，所以代码真的很慢。我做了一个j = 1000的测试，使参考时间等于20秒。

你有什么加快代码速度的建议吗?TY。

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

Answer 1

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