2行ずつのデータ貼り付けの処理を速くしたい（VBA）

二つのワークシートがあり、特定の行から2行ずつ1行飛ばしでデータをコピー、ペーストしたいと
思っています。

VBA初心者なのでインターネットで調べながら下記のようにして処理しようとしているのですが、
データ数が多い（3000行ぐらいある）ので、応答なしになるぐらい処理が遅いです。
処理を速く出来るように組み替えたいのですが、構文をご教授頂けないでしょうか？

・ワークシートDATA1をコピーしてワークシートDATAの同じ行に貼り付ける
・処理開始行は、Aセルの先頭から空白行を除いた＋2行目（変数FirstRowを使っています）
・処理終了行は、Aセルの最終行（変数lastRowを使っています。
・2行ごとコピーしてペースト⇒1行空けて2行ごとコピーしてペースト⇒・・・

下記で例えば
FirstRow＝57
lastRow＝2247
の場合、
DATA1の59、60行目をコピーして、DATAの59、60行目にペースト
↓
DATA1の62、63行目をコピーして、DATAの62、63行目にペースト
↓
DATA1の65、66行目をコピーして、DATAの65、66行目にペースト
↓
を最終行まで繰り返しです。


Sub TEST1()
Dim lastRow As Long
Dim FirstRow As Long
Dim cnt As Integer
FirstRow = Sheets("DATA1").Columns("A").End(xlDown).Row
lastRow = Sheets("DATA1").Cells(Rows.Count, "A").End(xlUp).Row

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.DisplayAlerts = False

For cnt = 0 To lastRow - FirstRow
　 Sheets("DATA1").Select
　 Rows(FirstRow + 2 + cnt & ":" & FirstRow + 3 + cnt).Copy '59,60
　 Sheets("DATA").Select
　 Rows(FirstRow + 2 + cnt & ":" & FirstRow + 3 + cnt). Select'59,60
　 ActiveSheet.Paste
　 cnt = cnt + 3
Next

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.DisplayAlerts = True

End Sub

質問者からの補足コメント

• すみません。
  ValueをFormulaに変更したら意図通りに動作しました。
  ありがとうございました。

  No.1の回答に寄せられた補足コメントです。 補足日時：2019/04/22 16:48

No.1 ベストアンサー 回答者： tom04 回答日時： 2019/04/22 16:14

こんにちは！

お示しのコードは行全体をコピー＆ペーストになっていますが、
値だけの操作にしてみてはどうでしょうか？

一例です。

Sub Sample1()
　Dim i As Long
　Dim myStart As Long, lastCol As Long
　Dim wS As Worksheet
　　Set wS = Worksheets("DATA")
　　　With Worksheets("DATA1")
　　　　myStart = .Range("A1").End(xlDown).Row
　　　　　For i = myStart + 2 To .Cells(Rows.Count, "A").End(xlUp).Row Step 4
　　　　　　lastCol = .Cells(i, Columns.Count).End(xlToLeft).Column
　　　　　　wS.Cells(i, "A").Resize(2, lastCol).Value = .Cells(i, "A").Resize(2, lastCol).Value
　　　　　Next i
　　　End With
　　　　MsgBox "完了"
End Sub

こんな感じで・・・m(_ _)m

この回答へのお礼

ありがとうございます。
説明不足で申し訳ございません。
行ごとコピー、ペーストとしたかったのは、A列以外も含めてその行を丸ごとコピーしたかった為です。
（具体的には特定の列以降に数式が入っており、それをDATAに行ごとコピーしたかったのです）

ご教授頂きました中で、下記を行指定にすれば行けるでしょうか？
wS.Cells(i, "A").Resize(2, lastCol).Value = .Cells(i, "A").Resize(2, lastCol).Value

お礼日時：2019/04/22 16:41