vba シート間でくりかえしコピー

ちょっと解りづらいと思うのですが・・・
前提
Sheet１～３に同じ書式で写真（結合セルに貼り付け）とその右に説明文がいくつか書いてあります。
Sheet１・・・写真①～③、３セル空いて写真④～⑥、３セル空いて以下続く
Sheet２・・・写真あ～う、３セル空いて写真え～か、３セル空いて以下続く
Sheet３・・・写真Ａ～Ｃ、３セル空いて写真Ｄ～Ｆ、３セル空いて以下続く

やりたいこと
sheet４にそれぞれのsheetから写真と説明をコピーして貼り付ける。
順番はSheet１の写真①→Sheet2の写真あ→Sheet3の写真A
３セル空いてSheet１の写真②→Sheet2の写真い→Sheet3の写真B
というような感じなのですが・・・。
Sheet４には最初から同じ枠組みがあってもいいですし、新しく書いてもいいですが同じフォーマットである必要があります。

Sub test()
Sheets(1).Cells(4, 1).Resize(10, 7).Copy
Sheets(4).Cells(4, 1).Resize(10, 7).Select
ActiveSheet.Paste

Sheets(2).Cells(4, 1).Resize(10, 7).Copy
Sheets(4).Cells(14, 1).Resize(10, 7).Select
ActiveSheet.Paste

Sheets(3).Cells(4, 1).Resize(10, 7).Copy
Sheets(4).Cells(24, 1).Resize(10, 7).Select
ActiveSheet.Paste
End Sub

↑のようなコードを繰り返せばできるのでしょうが、いかんせん量が多いもので、もっと効率の良いコードはないでしょうか？
For~NEXTでやっても途中３セル開いているためうまくいきません。
助けてください。

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

• 

  ありがとうございます。
  ちょっと自分のスキルでは解読に時間がかかりそうですがやってみます。
  sheet1～3は3*5枚で同じ枚数、sheet4は15*3シートで45枚です。
  sheet4は図形と文字を消してからペーストしてるのでしょうか？
  あと、下から５行目の「.Rows(1 & ":" & 6).Delete」が何を意味するのか教えて頂けませんか？

  No.2の回答に寄せられた補足コメントです。 補足日時：2015/11/10 22:46

No.3 回答者： tom04 回答日時： 2015/11/10 22:57

No.2です。

＞下から５行目の「.Rows(1 & ":" & 6).Delete」が何を意味するのか教えて頂けませんか？
について・・・

試しにその行を削除してマクロを実行してみてください。
1～6行目に不要な行があるため、最初の行を4行目に調整するためです。

※　10行おき（場合によっては13行おき）と規則的に処理を行いたいため
このようになってしまいました。

※　＞For Each mySp In .Shapes　
の行から7～8行は不要かもしれませんが、
①　Sheet4のデータを一旦すべて消去（画像も含む）
②　Sheet1～Sheet3で最大行を取得

以上の2点の処理を行っています。m(_ _)m

No.2 回答者： tom04 回答日時： 2015/11/10 22:08

こんばんは！

＞いかんせん量が多いもので・・・
とありますので、「写真」があるだけやってみました。
尚、Sheet1～Sheet3の最終行は同じだとします。

Sub Sample1()
Dim i As Long, k As Long, cnt As Long
Dim myMax As Long, myRow As Long
Dim wS As Worksheet, mySp As Shape

Application.ScreenUpdating = False
With Worksheets(4)
For Each mySp In .Shapes
mySp.Delete
Next mySp
.Range("A:G").Delete
For k = 1 To 3
myMax = WorksheetFunction.Max(myMax, Worksheets(k).Cells(Rows.Count, "E").End(xlUp).Row)
Next k
For i = 4 To myMax Step 10
If i Mod 33 = 1 Then
i = i + 3
End If
For k = 1 To 3
cnt = cnt + 1
If cnt > 1 And cnt Mod 3 = 1 Then
myRow = myRow + 3
End If
myRow = myRow + 10
Set wS = Worksheets(k)
wS.Cells(i, "A").Resize(10, 7).Copy .Cells(myRow, "A")
Next k
Next i
.Rows(1 & ":" & 6).Delete
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　Sheetによって「写真」の数が異なると、最大のSheetの数に合わせていますので
空白セルがそのままコピー＆ペーストされてしまいます。m(_ _)m

No.1 回答者： hiro40199210 回答日時： 2015/11/10 13:38

こんな感じでどうでしょう？　動作は確認済みですが、ForNextを三回繰り返しているので、あまり綺麗なコードではありません。

Sheet3の写真Ｃまでです。計９枚

変数kは、Sheet4に貼り付ける位置
変数rは、それぞれのシートからコピーする位置です。
(CP=Sheet4にコピペ）

k=4(初期値）
r=4(初期値）
For
Sheet１①(CP)→Sheet2あ(CP)→Sheet3A(CP)
Next

k=k+3
r=r+10
For
Sheet１②(CP)→Sheet2い(CP)→Sheet3B(CP)
k=k+3
r=r+10
Next

For
Sheet１③(CP)→Sheet2う(CP)→Sheet3C(CP)
Next

-----------------------------------------

Sub Test()
Dim i, k, r
Dim PasteSh As Worksheet
Set PasteSh = Sheets("Sheet4")

PasteSh.DrawingObjects.Delete

k = 4
r = 4
For i = 1 To 3
Sheets(i).Cells(r, 1).Resize(10, 7).Copy PasteSh.Cells(k, 1)
k = k + 10
Next

r = r + 10
k = k + 3
For i = 1 To 3
Sheets(i).Cells(r, 1).Resize(10, 7).Copy PasteSh.Cells(k, 1)
k = k + 10
Next

r = r + 10
k = k + 3
For i = 1 To 3
Sheets(i).Cells(r, 1).Resize(10, 7).Copy PasteSh.Cells(k, 1)
k = k + 10
Next

End Sub

この回答へのお礼

ありがとうございます。
コピー元と先で変数を分けるのは思いつきませんでした。
例えばSheet1～3の写真がもっとあった場合、
For i = 1 to 5 とかにしても・・・できないですね。うーん。
参考にさせてもらいます！

お礼日時：2015/11/10 22:51