複製目的地方法不適用於大量數據/公式

Question

如果iRow高達40,000（注意它總共導致3,720,000個公式......），下面提取的代碼工作正常。我現在需要爲100,000以上的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 

在這個問題上的任何燈光將非常讚賞。

配置：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其他的東西不過，如果這仍然是給你麻煩。

EDIT＃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