复制目标方法不适用于大量的数据/公式

下面提取的代码是完美的工作，如果iRow是高达40,000（注意，它导致总共3,720,000公式…）。 我现在需要为10万以上的iRow做同样的事情，如果结束的话，它是成倍的BAD …我把PC打开了一天以上，但是没有。

Dim iRow As LongPtr Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False Application.Calculation = xlCalculationManual WSD.Range("K2:CZ2").Copy Destination:=WSD.Range("K3:CZ" & iRow) Application.Calculation = xlCalculationAutomatic Application.Calculation = xlCalculationManual WSD.Range("K3:CZ" & iRow).Value = WSD.Range("K3:CZ" & iRow).Value Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True 

在这个问题上的任何亮点将非常感激。

configuration：Excel 2010 x64 VBA7 WIN64

Answer 1

这对我来说，花了不到30秒：

 Sub CopyExample() Dim iRow As Long Dim calcState As Long iRow = 100000 calcState = Application.Calculation Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ActiveSheet.Range("A1:CZ1").Copy Destination:=ActiveSheet.Range("A2:CZ" & iRow) Application.Calculation = calcState Application.ScreenUpdating = True End Sub 

你可能想要做的不是。 .Copy但如果这仍然给你麻烦。

编辑＃1尝试使用AutoFill方法，而不是Copy方法。 对于50,000行，这需要2分钟。 我的虚拟数据具有不稳定的Rand()函数，以及另一个基于此函数的函数，覆盖了来自A1：CZ1的所有列。

 Option Explicit Sub CopyExample2() Dim iRow As Long Dim calcState As Long Dim sourceRange As Range Dim pasteRange As Range Dim t As Long t = Timer iRow = 100000 calcState = Application.Calculation 'Turn off screenupdating, calculation, etc.' Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set sourceRange = ActiveSheet.Range("A1:CZ1") Set pasteRange = ActiveSheet.Range("A1:CZ" & iRow) With sourceRange .AutoFill pasteRange End With 'Turn on calculation, screenupdating, etc.' Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Debug.Print Timer - t End Sub