循环内的Excel VBA复制操作非常慢

Question

以下子在其循环中有一个 Copy 语句，在 Excel 2013 中执行需要超过 2 秒。因此，对于 20 次迭代，这将超过 40 秒。我已经尝试了所有常用的优化方法，比如禁用事件和屏幕更新。有没有人有同样的问题？

Sub TEST_SUB(surface)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Worksheets("Sheet3").Activate
    ActiveSheet.DisplayPageBreaks = False

    Sheets("Sheet3").Range("A4:Z400").ClearContents


y = 4   'y is the row on sheet3 where we want to paste
For x = 4 To 20 'x is the current row from which we want to copy
        ' Decide if to copy based on whether the value in col 10 matches the parameter Surface
        ThisValue = Sheets("Tests_Master").Cells(x, 10).Value
        If ThisValue = surface Or x = 4 Then
            R1 = "A" + CStr(x) + ":K" + CStr(x) 'Range to copy from: row X columns 1-10

            'This next statement taks about 2 seconds to execute ! WHY????
            Sheets("Tests_Master").Range(R1).Copy Destination:=Sheets("sheet3").Range("A" + CStr(y))
            y = y + 1

        End If

Next x
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Answer 1

我做了一些修改，使用提示

Optimize your code by explicitly reducing the number of times data is transferred between Excel and your code. Instead of looping through cells one at a time to get or set a value, get or set the values in the entire range of cells in one line, using a variant containing a two-dimensional array to store values as needed.

从此article我修改了你的代码:

Sub TEST_SUB(surface)
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    Worksheets("Sheet3").Activate
    ActiveSheet.DisplayPageBreaks = False

    Sheets("Sheet3").Range("A4:Z400").ClearContents    

    y = 4   'y is the row on sheet3 where we want to paste
    For x = 4 To 20 'x is the current row from which we want to copy
    ' Decide if to copy based on whether the value in col 10 matches the parameter Surface
        ThisValue = Sheets("Tests_Master").Cells(x, 10).value
        If ThisValue = surface Or x = 4 Then
            R1 = "A" + CStr(x) + ":K" + CStr(x) 'Range to copy from: row X columns 1-10

            'Is faster use an array to store a range to copy after
            rangeToCopy = Sheets("Tests_Master").Range(R1)
            Sheets("sheet3").Range("A" + CStr(y) + ":K" + CStr(y)) = rangeToCopy

            'This next statement taks about 2 seconds to execute ! WHY????
            'Sheets("Tests_Master").Range(R1).Copy Destination:=Sheets("sheet3").Range("A" + CStr(y))
            y = y + 1

        End If

    Next x

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

P.S.:对不起我的英语