如何简化VBA代码以更快地运行

Question

相对较新的VBA编码器，我有一个运行缓慢的excel宏。

以下代码用于从一张表(例如，Sheet12"CLIENT 1"(中获取非空白数据行，并根据单元格值将它们移动到其他表中。数据可以发送到5张表中的一张，并且有4张数据需要排序。

代码目前可以工作，但运行速度非常慢，尤其是在有大量数据的情况下。有没有更好的方法来编写这些代码以加快运行时间？

Private Sub REFRESH_DATA()
Sheet3.Range("A3:Z2000").ClearContents            'Clear GREEN_Data
Sheet5.Range("A3:Z2000").ClearContents            'Clear BLUE_Data
Sheet7.Range("A3:Z2000").ClearContents            'Clear PURPLE_Data
Sheet9.Range("A3:Z2000").ClearContents            'Clear YELLOW_Data
Sheet11.Range("A3:Z2000").ClearContents           'Clear ORANGE_Data
Application.ScreenUpdating = False                'Stop screen from flashing
Dim s As Long
Dim AA As Long
Dim AB As Long
Dim AC As Long
Dim AD As Long
Dim A1 As Long
Dim A2 As Long
Dim A3 As Long
Dim A4 As Long
Dim A5 As Long
AA = Sheet12.Range("A" & Sheet12.Rows.Count).End(xlUp).Row  'Project List - Client 1
AB = Sheet13.Range("A" & Sheet13.Rows.Count).End(xlUp).Row  'Project List - Client 2
AC = Sheet14.Range("A" & Sheet14.Rows.Count).End(xlUp).Row  'Project List - Client 3
AD = Sheet15.Range("A" & Sheet15.Rows.Count).End(xlUp).Row  'Project List - Client 4
A1 = Sheet3.Range("A" & Sheet3.Rows.Count).End(xlUp).Row     'GREEN_Data
A2 = Sheet5.Range("A" & Sheet5.Rows.Count).End(xlUp).Row     'BLUE_Data
A3 = Sheet7.Range("A" & Sheet7.Rows.Count).End(xlUp).Row     'PURPLE_Data
A4 = Sheet9.Range("A" & Sheet9.Rows.Count).End(xlUp).Row     'YELLOW_Data
A5 = Sheet11.Range("A" & Sheet11.Rows.Count).End(xlUp).Row   'ORANGE_Data
For s = 5 To AA     'Project List - Client 1
If Sheet12.Cells(s, 28).Value = True Then
Sheet12.Range("A" & s).Resize(ColumnSize:=27).Copy
A1 = A1 + 1
Sheet3.Range("A" & A1).PasteSpecial Paste:=xlPasteValues     'GREEN_Data
End If
If Sheet12.Cells(s, 29).Value = True Then
Sheet12.Range("A" & s).Resize(ColumnSize:=27).Copy
A2 = A2 + 1
Sheet5.Range("A" & A2).PasteSpecial Paste:=xlPasteValues     'BLUE_Data
End If
If Sheet12.Cells(s, 30).Value = True Then
Sheet12.Range("A" & s).Resize(ColumnSize:=27).Copy
A3 = A3 + 1
Sheet7.Range("A" & A3).PasteSpecial Paste:=xlPasteValues     'PURPLE_Data
End If
If Sheet12.Cells(s, 31).Value = True Then
Sheet12.Range("A" & s).Resize(ColumnSize:=27).Copy
A4 = A4 + 1
Sheet9.Range("A" & A4).PasteSpecial Paste:=xlPasteValues     'YELLOW_Data
End If
If Sheet12.Cells(s, 32).Value = True Then
Sheet12.Range("A" & s).Resize(ColumnSize:=27).Copy
A5 = A5 + 1
Sheet11.Range("A" & A5).PasteSpecial Paste:=xlPasteValues    'ORANGE_Data
End If
Next s
For s = 5 To AB     'Project List - Client 2
If Sheet13.Cells(s, 28).Value = True Then
Sheet13.Range("A" & s).Resize(ColumnSize:=27).Copy
A1 = A1 + 1
Sheet3.Range("A" & A1).PasteSpecial Paste:=xlPasteValues     'GREEN_Data
End If
If Sheet13.Cells(s, 29).Value = True Then
Sheet13.Range("A" & s).Resize(ColumnSize:=27).Copy
A2 = A2 + 1
Sheet5.Range("A" & A2).PasteSpecial Paste:=xlPasteValues     'BLUE_Data
End If
If Sheet13.Cells(s, 30).Value = True Then
Sheet13.Range("A" & s).Resize(ColumnSize:=27).Copy
A3 = A3 + 1
Sheet7.Range("A" & A3).PasteSpecial Paste:=xlPasteValues     'PURPLE_Data
End If
If Sheet13.Cells(s, 31).Value = True Then
Sheet13.Range("A" & s).Resize(ColumnSize:=27).Copy
A4 = A4 + 1
Sheet9.Range("A" & A4).PasteSpecial Paste:=xlPasteValues     'YELLOW_Data
End If
If Sheet13.Cells(s, 32).Value = True Then
Sheet13.Range("A" & s).Resize(ColumnSize:=27).Copy
A5 = A5 + 1
Sheet11.Range("A" & A5).PasteSpecial Paste:=xlPasteValues    'ORANGE_Data
End If
Next s
For s = 5 To AC     'Project List - Client 3
If Sheet14.Cells(s, 28).Value = True Then
Sheet14.Range("A" & s).Resize(ColumnSize:=27).Copy
A1 = A1 + 1
Sheet3.Range("A" & A1).PasteSpecial Paste:=xlPasteValues     'GREEN_Data
End If
If Sheet14.Cells(s, 29).Value = True Then
Sheet14.Range("A" & s).Resize(ColumnSize:=27).Copy
A2 = A2 + 1
Sheet5.Range("A" & A2).PasteSpecial Paste:=xlPasteValues     'BLUE_Data
End If
If Sheet14.Cells(s, 30).Value = True Then
Sheet14.Range("A" & s).Resize(ColumnSize:=27).Copy
A3 = A3 + 1
Sheet7.Range("A" & A3).PasteSpecial Paste:=xlPasteValues     'PURPLE_Data
End If
If Sheet14.Cells(s, 31).Value = True Then
Sheet14.Range("A" & s).Resize(ColumnSize:=27).Copy
A4 = A4 + 1
Sheet9.Range("A" & A4).PasteSpecial Paste:=xlPasteValues     'YELLOW_Data
End If
If Sheet14.Cells(s, 32).Value = True Then
Sheet14.Range("A" & s).Resize(ColumnSize:=27).Copy
A5 = A5 + 1
Sheet11.Range("A" & A5).PasteSpecial Paste:=xlPasteValues    'ORANGE_Data
End If
Next s
For s = 5 To AD     'Project List - Client 4
If Sheet15.Cells(s, 28).Value = True Then
Sheet15.Range("A" & s).Resize(ColumnSize:=27).Copy
A1 = A1 + 1
Sheet3.Range("A" & A1).PasteSpecial Paste:=xlPasteValues     'GREEN_Data
End If
If Sheet15.Cells(s, 29).Value = True Then
Sheet15.Range("A" & s).Resize(ColumnSize:=27).Copy
A2 = A2 + 1
Sheet5.Range("A" & A2).PasteSpecial Paste:=xlPasteValues     'BLUE_Data
End If
If Sheet15.Cells(s, 30).Value = True Then
Sheet15.Range("A" & s).Resize(ColumnSize:=27).Copy
A3 = A3 + 1
Sheet7.Range("A" & A3).PasteSpecial Paste:=xlPasteValues     'PURPLE_Data
End If
If Sheet15.Cells(s, 31).Value = True Then
Sheet15.Range("A" & s).Resize(ColumnSize:=27).Copy
A4 = A4 + 1
Sheet9.Range("A" & A4).PasteSpecial Paste:=xlPasteValues     'YELLOW_Data
End If
If Sheet15.Cells(s, 32).Value = True Then
Sheet15.Range("A" & s).Resize(ColumnSize:=27).Copy
A5 = A5 + 1
Sheet11.Range("A" & A5).PasteSpecial Paste:=xlPasteValues    'ORANGE_Data
End If
Next s
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

提前感谢您的帮助！

Answer 1

应该更快：

Private Sub REFRESH_DATA()
Const COPY_COLS As Long = 27
Dim ws, rw As Long, arrDestSheets, arrDestRows, n As Long

Application.ScreenUpdating = False                'Stop screen from flashing

'sheets to copy to:    green  blue    purple  yellow  orange
arrDestSheets = Array(Sheet3, Sheet5, Sheet7, Sheet9, Sheet11)
arrDestRows = Array(3, 3, 3, 3, 3) 'destination rows in each sheet

'clear all destination sheets
For Each ws In arrDestSheets
ws.Range("A3:Z2000").ClearContents
Next ws

For Each ws In Array(Sheet12, Sheet13, Sheet14, Sheet15)
For rw = 5 To ws.Cells(Rows.Count, 1).End(xlUp).Row
For n = 0 To 4
If ws.Cells(rw, 28 + n) = True Then
arrDestSheets(n).Cells(arrDestRows(n), 1).Resize(1, COPY_COLS).Value = _
ws.Cells(rw, 1).Resize(1, COPY_COLS).Value
arrDestRows(n) = arrDestRows(n) + 1
'Exit For  'uncomment if only one match per row
End If
Next n
Next rw
Next ws

Application.ScreenUpdating = True
End Sub

Answer 2

要做的第一件事：删除"复制粘贴"结构，正如你在这里看到的：

您的代码：

Sheet12.Range("A" & s).Resize(ColumnSize:=27).Copy
A1 = A1 + 1
Sheet3.Range("A" & A1).PasteSpecial Paste:=xlPasteValues     'GREEN_Data

我的建议：

Sheet12.Range("A" & s).Resize(ColumnSize:=27)
A1 = A1 + 1
Sheet3.Range("A" & A1).Value = Sheet12.Range("A" & s).Value    'GREEN_Data

像这样，你可以避免跳过剪贴板，在我看来，这是一个巨大的性能下降。