非連続したデータを別シートに転記するマクロ

前回質問した際に添付が間違っていたため再度質問します。
（アドバイスくれた方、ありがとうございます＆申し訳ありませんでした）
ちなみにExcelは2013を使用しております。

sheet1:　データがある表
sheet2:　sheet1のデータを転記する表
両方とも項目が１行目にあります。
ちなみにこの並びの数に変動はなく、
【店名　担当者①　担当者② 売上①　売上② 内訳 　内訳】の並びは7回ほど繰り返され
ところどころに空白があります。

sheet1
A 列　　　　B　　　　　C　　　　D　　　　　E　　　　　Ｆ　　　G　　　H　　　　　I～
商品名 店舗 　　　店名 　　担当者① 担当者② 売上①　売上② 内訳 　　　内訳
マフィン 神奈川 横浜 　　鈴木　　 佐藤　　 10 　　15 チョコ イチゴ
ベーグル 千葉 　　　柏 　　飯田　　　　佐藤　　 20 　　10 ごま

sheet２の並び
商品名 店舗 　　　店名 　　担当者① 売上①　担当者②　売上② 内訳 　　　内訳

上記の図のように商品名、店舗、店名（A～C）はそのままに
担当者が変わったら添付画像のように行を変えて転記したいです。
並べたい順が非連続した場合、どのようにマクロを組めばよろしいでしょうか。

アドバイスよろしくお願いします。

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

• 項目画像を拡大しました。

  
    補足日時：2019/05/12 11:08

No.1 ベストアンサー 回答者： tom04 回答日時： 2019/05/12 11:46

こんにちは！

https://oshiete.goo.ne.jp/qa/11113393.html
　↑のサイトの続きですね。

よく見るとSheet1の列順ではなく、担当者①　→　売上①　→　担当者②　→　売上②　の順で表示しなければならないのですね。
今回は7列で一つの塊だと解釈して・・・
前回同様、両シートとも1行目は項目行でデータは2行目以降にあるとします。

一例です。
標準モジュールにしてください。

Sub Sample2()
　Dim i As Long, j As Long, k As Long
　Dim cnt As Long, lastRow As Long
　Dim wS As Worksheet, myRng As Range
　Dim myAry

　　Set wS = Worksheets("Sheet1")
　　　With Worksheets("Sheet2")
　　　　'//Sheet2のデータを一旦消去//
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　If lastRow > 1 Then
　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "I")).ClearContents
　　　　　End If

　　　　　　myAry = Array(1, 2, 4, 3, 5, 6, 7)
　　　　　　cnt = 1
　　　　　　For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　For j = 3 To wS.Cells(i, Columns.Count).End(xlToLeft).Column Step 7
　　　　　　　　Set myRng = wS.Cells(i, j).Resize(, 7)
　　　　　　　　　cnt = cnt + 1
　　　　　　　　　　.Cells(cnt, "A").Resize(, 2).Value = wS.Cells(i, "A").Resize(, 2).Value
　　　　　　　　　　　For k = 0 To UBound(myAry)
　　　　　　　　　　　　.Cells(cnt, k + 3).Value = myRng(myAry(k))
　　　　　　　　　　　Next k
　　　　　　　Next j
　　　　　　Next i
　　　End With
End Sub

今度はどうでしょうか？m(_ _)m

この回答へのお礼

前回に引き続き早々にありがとうございます！！
この作業にずーっとかかりきりだったので感謝です！！

お礼日時：2019/05/12 12:04