循环内的Excel VBA Copy操作非常慢

下面的子程序在其循环中有一个复制语句，需要2秒钟才能在Excel 2013中执行。因此，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

我做了一些修改，使用小费

通过明确减less数据在Excel和代码之间传输的次数来优化代码。 取而代之的是一次循环一个单元格来获取或设置一个值，使用一个包含二维数组的variables来获取或设置整行单元格中的值。

从这篇文章我修改你的代码：

 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 

PS：对不起，我的英语