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

以下是一些指针：

记住要声明所有变量，并在代码顶部使用Option Explicit
使用With语句来确保使用正确的工作表而不是隐式的活动表，否则最终行数可能会出错
只有i参与循环，因此您在进行不必要的循环工作
使用Union收集排位赛范围并一口气复制
记住要重新打开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

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

1 个答案: