VBA マクロ処理時間の短縮について

質問

下記のコードを作りましたが、マクロを実行すると砂時計マークが表示されて、処理が終了するまでに３０秒くらいかかります。
コードを変更して、マクロ処理時間を短縮する事はできないでしょうか？

Sub A列のコピー()
Dim rw2 As Long
Dim rw1 As Long
Dim newdate As Date
With Worksheets("sheet1")
rw2 = .cells(.Rows.Count, "c").End(xlUp).Row
newdate = .Range("c" & rw2).value
For rw1 = rw2 - 1 To 1 Step -1
If .Range("c" & rw1).value <> newdate Then Exit For
Next rw1
.Range(.cells(rw1 + 1, 1), .cells(rw2, 1)).Copy
Worksheets("sheet2").Range("v6").PasteSpecial xlValue
If rw1 + 26 <= rw2 Then
.Range(.cells(rw1 + 26, 1), .cells(rw2, 1)).Copy
Worksheets("sheet2").Range("v40").PasteSpecial xlValue
Application.CutCopyMode = False
End If
Application.CutCopyMode = False
End With
End Sub
各セルは、６０００行くらいまで表示されています。
　よろしくお願いします。

回答No.2

ham_kamo · ベストアンサー

No.1です。Resizeを使えばもうちょっと短くなることに気がついたので、改訂版です。

Sub A列のコピー()
　Dim rw2 As Long
　Dim rw1 As Long
　Dim newdate As Date
　With Worksheets("sheet1")
　　rw2 = .Cells(.Rows.Count, "c").End(xlUp).Row
　　newdate = .Range("c" & rw2).Value
　　For rw1 = rw2 - 1 To 1 Step -1
　　　If .Range("c" & rw1).Value <> newdate Then Exit For
　　Next rw1
　　Worksheets("sheet2").Cells(6, "v").Resize(rw2 - rw1).Value = _
　　.Range(.Cells(rw1 + 1, 1), .Cells(rw2, 1)).Value
　　If rw1 + 26 <= rw2 Then
　　　Worksheets("sheet2").Cells(40, "v").Resize(rw2 - (rw1 + 26) + 1).Value = _
　　　.Range(.Cells(rw1 + 26, 1), .Cells(rw2, 1)).Value
　　End If
　End With
End Sub

お礼

ご回答ありがとうございました。
試したところ、砂時計マークも出ず反応がかなり早くなりました。

回答No.1

ham_kamo

とりあえず、形式を選択して値で貼り付けしている部分を、コピー先の範囲をRangeで明示的に指定して直接Valueを代入するようにしてみました。
検証はしていないので、違う結果になったり速くならなかったらすみません。

Sub A列のコピー()
　Dim rw2 As Long
　Dim rw1 As Long
　Dim newdate As Date
　With Worksheets("sheet1")
　　rw2 = .Cells(.Rows.Count, "c").End(xlUp).Row
　　newdate = .Range("c" & rw2).Value
　　For rw1 = rw2 - 1 To 1 Step -1
　　　If .Range("c" & rw1).Value <> newdate Then Exit For
　　Next rw1　　
　　Worksheets("sheet2").Range(Cells(6, "v"), Cells(6 + rw2 - rw1), "v").Value = _
　　.Range(.Cells(rw1 + 1, 1), .Cells(rw2, 1)).Value
　　If rw1 + 26 <= rw2 Then
　　　Worksheets("sheet2").Range(Cells(40, "v"), Cells(40 + (rw2 - (rw1 + 26) + 1)), "v").Value = _
　　　.Range(.Cells(rw1 + 26, 1), .Cells(rw2, 1)).Value
　　End If
　End With
End Sub