VBAの構文 3列置きにコピーして別シートに貼付

VBA入門者です。宜しくお願いします。

以下の作業を、シート（1）～（3）に繰り返したいのです

　
　◎シート（”レポート”）列A,C,F…40列まで3列置きにコピー
　◎シート（１）のA3に貼付

初歩的な構文だとシートごとに設定するのが大変です（汗）
下の構文をコンパクトにまとめ、
できれば・・・
シート(2)には（B4,B23)～、シート(3)には（C4,C23)～同じ流れでコピペする動作も
まとめたいのです。

　　With Worksheets("レポート")

.Range("A4:A23").Copy
Worksheets("1").Range("A3").PasteSpecial xlPasteValues

.Range("C4:C23").Copy
Worksheets("1").Range("B3").PasteSpecial xlPasteValues

.Range("F4:F23").Copy
Worksheets("1").Range("C3").PasteSpecial xlPasteValues

.Range("I4:I23").Copy
Worksheets("1").Range("D3").PasteSpecial xlPasteValues

'……４０列まで続く
End With

No.1 ベストアンサー 回答者： tom04 回答日時： 2015/06/09 14:26

こんにちは！

＞'……４０列まで続く
とは「レポート」Sheetの40列（AN列）までというコトでしょうか？
それともデータがある限り3列毎に40回同じ操作を繰り返す！というコトなのでしょうか？
質問文では
A・C・F・I・・・
となっていますので、
A列はそのまま値をコピー＆ペーストし、C列以降3列毎というコトですよね？

二つやってみました。
「Sample1」がAN列までで、「Sample2」がデータがある限りC列以降3列毎に40回コピー＆ペーストしています。

Sub Sample1()
Dim j As Long, cnt As Long, wS As Worksheet
Set wS = Worksheets("1")
With Worksheets("レポート")
.Range("A4:A23").Copy
wS.Range("A3").PasteSpecial Paste:=xlPasteValues
cnt = 1
For j = 3 To 40 Step 3 '//C列～AN列まで3列毎
cnt = cnt + 1
Range(.Cells(4, j), .Cells(23, j)).Copy
wS.Cells(3, cnt).PasteSpecial Paste:=xlPasteValues
Next j
End With
End Sub

Sub Sample2()
Dim j As Long, cnt As Long, wS As Worksheet
Set wS = Worksheets("1")
With Worksheets("レポート")
.Range("A4:A23").Copy
wS.Range("A3").PasteSpecial Paste:=xlPasteValues
For j = 3 To .UsedRange.Columns.Count Step 3 '//C列～最終列まで3列毎
If cnt = 40 Then Exit For '//40回繰り返したらループから抜ける★
cnt = cnt + 1
Range(.Cells(4, j), .Cells(23, j)).Copy
wS.Cells(3, cnt + 1).PasteSpecial Paste:=xlPasteValues
Next j
End With
End Sub

こんな感じで良いのでしょうか？m(_ _)m

この回答へのお礼

tom04さんへ

ありがとうございます！！
【Sample1】を参考にさせていただきました！
本当に助かりました！
これで、上手く行きそうです！
感謝♡

お礼日時：2015/06/10 17:02