加快 VBA 代码提取相关行到新工作表的速度

Question

我需要将相关行复制到新的 Excel 工作表。代码将遍历原始工作表中的每一行，并根据数组中指定的相关国家和产品选择行到第二个工作表中。

Private Sub CommandButton1_Click()

a = Worksheets("worksheet1").Cells(Rows.Count, 2).End(xlUp).Row
Dim countryArray(1 To 17) As Variant
Dim productArray(1 To 17) As Variant

' countryArray(1)= "Australia" and so on...
' productArray(1)= "Product A" and so on...

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 3 To a
    For Each j In countryArray
        For Each k In productArray
        Sheets("worksheet1").Rows(i).Copy Destination:=Sheets("worksheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
        Next
    Next
Next

Application.CutCopyMode = False
Application.ScreenUpdating = False

End Sub

每次我运行代码时，电子表格都会在几分钟内停止响应。如果有人可以帮助我，将不胜感激，在此先感谢！

Answer 1

这里有一些提示：

1. 记得声明所有变量并在代码顶部使用Option Explicit
2. 使用With 语句确保使用正确的工作表而不是隐式的活动表，否则您可能会得到错误的结束行数
3. 只有 i 对循环有贡献，所以你在做不必要的循环工作
4. 使用Union 收集符合条件的范围并一次性复制
5. 记得重新开启screen-updating

代码：

Option Explicit
Private Sub CommandButton1_Click()
    Dim unionRng As Range, a As Long, i As Long
    With Worksheets("worksheet1")
        a = .Cells(.Rows.Count, 2).End(xlUp).Row

        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual

        For i = 3 To a
            If Not unionRng Is Nothing Then
                Set unionRng = Union(unionRng, .Cells(i, 1))
            Else
                Set unionRng = .Cells(i, 1)
            End If
        Next

        With Worksheets("worksheet2")
            unionRng.EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Row +1
        End With
    End With

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub