一定の組み合わせを行毎にして転記するマクロ

いつもお世話になっております。
Excel2013を使用しておりますので、どうかアドバイスをお願いします。

sheet1:　データがある表
sheet2:　sheet1のデータを転記する表
両方とも項目が１行目にあります。

sheet1
A 列　　B　　　C　　　　D　　　E　　　Ｆ
商品名　店舗　担当者①　担当者②　売上①　売上②
ああ　　横浜　鈴木　　　佐藤　　10　　　15
いいい　千葉　飯田　　　佐藤　　20　　　10

sheet2
A 列　　B　　　C　　　　D　　　
商品名　店舗　担当者　　売上
ああ　　横浜　鈴木　　　10　　　
ああ　　横浜　佐藤　　　15
いいい　千葉　飯田　　　20　　　
いいい　千葉　佐藤　　　10

上記の図のように商品名、店舗はそのままに
担当者が変わったら行を変えて転記したいです。
担当者①　売上①　担当者②　売上②のような形であれば出来たのですが
並べたい順が飛んでいる場合、どのようにマクロを組めばよろしいでしょうか。

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

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

• 現状は二つずつなのですが今後増える可能性があります

  
  No.1の回答に寄せられた補足コメントです。 補足日時：2019/05/10 09:17

• 説明文は簡略しておりました。
  混乱させて申し訳ないです。
  捕捉として今後店名も人数も増える可能性はあるのですが、いまあるのをなんとかしたいです(過去のデータが全然整理されていないので...)
  
  【店名】から次の【店名】の１つ前までの列数はこれが完全なものなのでしょうか？
  →画像に載せ切れなかったのですが実は15列あります。
  変動については今はないです。
  色々変わってすみませんがよろしくお願いします。

  No.6の回答に寄せられた補足コメントです。 補足日時：2019/05/11 21:07

• >これを以下のようにすることは可能でしょうか？
  
  お礼に記載した↑は間違いです。すみません。
  添付のような形が希望です。

  No.5の回答に寄せられた補足コメントです。 補足日時：2019/05/12 01:06

No.1 回答者： めぐみん_ 回答日時： 2019/05/10 08:48

担当者と売上は必ず２列ずつなのですか？

No.2 回答者： fujillin 回答日時： 2019/05/10 08:58

こんにちは

＞並べたい順が飛んでいる場合、どのようにマクロを組めばよろしいでしょうか
セル位置が変わるだけなので、ほぼ同じ要領です。

現状はどのように実現しているのかが不明なので、何が近いのかわかりませんが、現状が2セル分をまとめて転記していると仮定するならば、
　・1セルずつ転記する（処理を分ける）
　・まとめて転記する
　　　例）Range("A1,D1").Copy Destination:=Range("J1:K1")
などの様にすれば宜しいのではないでしょうか？

※ 後者の方法は、あまりお勧めできるものではありません。

この回答へのお礼

ありがとうございます。
やっぱり地道にやるしかないですかね...

お礼日時：2019/05/10 14:25

No.3 回答者： komugi3333 回答日時： 2019/05/10 16:49

「絶対にループなどを使ったVBAじゃないとダメ」、ということでしたら使えない方法かもしれませんけど、もしそこまでじゃないんでしたら・・・

今後も横に増える可能性（変動する可能性）があるのなら、また最初の表がこのデータの持ち方なら、担当者ひとりあたりの列数も同じようですし、とりあえずマクロの記録でもいいんじゃないでしょうか？（最初の表がどこかから回ってくる・・というのでしたら・・・。）

3人め、４人め、と増えても、マクロの記録で作り直せばいいと思います。


添付の図のような感じなのですが、次のようにして「マクロの記録」機能で作りました。

(01)Sheet1をCtrlキーを押しながら右へドラッグして複製（コピーを作成）
(02)F1の列を選択
(03)空白の列を追加
(04)もう一個空白の列を追加
(05)A1～B3（製品名と地域の列）のセルをドラッグで選択して、Ctrl+Cなどでコピー操作
(06)F1をクリック
(07)貼り付け（Ctrl＋V）
(08)F2～J3（２人めの担当者の部分）をドラッグで選択して切り取り（Ctrl＋X）
(09)A4セルをクリック
(10)貼り付け（Ctrl＋V）
(11)製品名を降順、地域を昇順で並べ替え
(12)F列より右の、列名だけが残った部分の列を削除

※既存のSheet2を消して、新しくできた表Sheet2にリネームする処理はマクロに含めませんでした。

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Macro9()
'
' Macro9 Macro
'

'
　　Sheets("Sheet1").Copy Before:=Sheets(2)
　　Columns("F:F").Select
　　Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
　　Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
　　Range("A1:B3").Select
　　Selection.Copy
　　Range("F1").Select
　　ActiveSheet.Paste
　　Range("F2:J3").Select
　　Application.CutCopyMode = False
　　Selection.Cut
　　Range("A4").Select
　　ActiveSheet.Paste
　　Range("A2").Select
　　ActiveWorkbook.Worksheets("Sheet1 (2)").Sort.SortFields.Clear
　　ActiveWorkbook.Worksheets("Sheet1 (2)").Sort.SortFields.Add Key:=Range( _
　　　　"A2:A5"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
　　　　xlSortNormal
　　ActiveWorkbook.Worksheets("Sheet1 (2)").Sort.SortFields.Add Key:=Range( _
　　　　"B2:B5"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
　　　　xlSortNormal
　　With ActiveWorkbook.Worksheets("Sheet1 (2)").Sort
　　　　.SetRange Range("A1:J5")
　　　　.Header = xlYes
　　　　.MatchCase = False
　　　　.Orientation = xlTopToBottom
　　　　.SortMethod = xlPinYin
　　　　.Apply
　　End With
　　Columns("F:K").Select
　　Selection.Delete Shift:=xlToLeft
　　Range("A1").Select
End Sub

この回答へのお礼

アドバイスありがとうございました。
はじめはその様に切り取り&貼り付けを行っていたのですがデータ数が多いせいかフリーズすることが多くて...。やはりこのやり方が一番地道ですかね。

お礼日時：2019/05/11 20:48

No.4 回答者： めぐみん_ 回答日時： 2019/05/10 19:49

No.1です。

今後増えるとして、

１・１行に対して必要なデータは必ず2人分である事は変わらない。
２・１行に対して今後は2人とは限らず人数の変動もある。
３・２に追加して行によっては２人のデータであったり４人のデータになる可能性もある。

など色々と考えてしまうのですが、その辺ではっきり決まった事（仕様変更がこの方法しかないなど）はあるのでしょうか？

あ。人数ではなく【店名】数って事になるのかな。
項目名が不思議ではありますが、【県名（又は【商品名】）】毎に【店名】数が一律なのかどうか。

No.5 ベストアンサー 回答者： tom04 回答日時： 2019/05/11 00:37

こんばんは！

横からお邪魔します。

両シートとも1行目が項目行でデータは2行目以降にあるという前提です。
標準モジュールにしてください。

Sub Sample1()
　Dim i As Long, j As Long
　Dim lastRow As Long, cnt As Long
　Dim wS As Worksheet
　　Set wS = Worksheets("Sheet1")
　　　With Worksheets("Sheet2")
　　　　lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　If lastRow > 1 Then
　　　　　　Range(.Cells(2, "A"), .Cells(lastRow, "K")).ClearContents
　　　　　End If
　　　　　　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 9
　　　　　　　cnt = cnt + 1
　　　　　　　With .Cells(cnt, "A")
　　　　　　　　.Resize(, 2).Value = wS.Cells(i, "A").Resize(, 2).Value
　　　　　　　　.Offset(, 2).Resize(, 9).Value = wS.Cells(i, j).Resize(, 9).Value
　　　　　　　End With
　　　　　　Next j
　　　　　Next i
　　　　.Activate
　　　End With
　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

アドバイスありがとうございました。
試してみたのですが順番が以下のようになりました。
A列 B C D E F G H I J K
A列 B L M N O P Q R S T

添付のようにすることは可能でしょうか？

これを以下のようにすることは可能でしょうか？

お礼日時：2019/05/11 20:58

No.6 回答者： めぐみん_ 回答日時： 2019/05/11 09:49

No.4です。

質問文と画像との書き出し条件が不一致なのは取り合えず避けて、画像にある【店名】から次の【店名】の１つ前までの列数はこれが完全なものなのでしょうか？
或いはそれさえも今後変動する可能性はあるのですか？
そして変動する場合でも　＜【店名】から次の【店名】の１つ前＞　と言う条件は変わらないと考えて良いのでしょうか？
何となく内容的にダミーな項目名である感じはしますけど、その場合でも同じ考えで良いのでしょうか？

No.7 回答者： komugi3333 回答日時： 2019/05/12 00:19

No3です。

＞はじめはその様に切り取り&貼り付けを行っていたのですが
＞データ数が多いせいかフリーズすることが多くて...。

もしそうでしたら、
（マクロの記録で）自動生成されたVBAプログラムの先頭の行のそのまた上に、

Application.ScreenUpdating = False

という1行をコピペして動かしてみてください。

画面の描画がなされなくなりますので、もしかしたら、フリーズしなくなるかもしれません・・・。

それでもフリーズするようなら、何か裏でExcel以外の別のプログラム（重たい動きをするプログラムとか）が動いているせいかもしれないので、タスクマネージャで変なものが動いていないか確認してください。

もちろん、他の方のご回答のほうを優先してください。
（私がマクロの記録でのVBAプログラムの自動作成をご紹介したのは、もしかしてお時間的な余裕がないかもしれないと思ったからと構造がシンプルっぽかった、ただそれだけですので・・・。）

No.8 回答者： めぐみん_ 回答日時： 2019/05/12 04:06

No.6です。

No.5さんの結果と画像を見比べても同じようにしか見えないのですが、具体的にどこが違うのでしょう？（老眼のせいかな？）
それとも画像が９列で実際は１５列って点でずれてしまっているだけかな？

切り貼りはやり方によってはメモリを消費します（幾ら物理的メモリを増やしていてもＥｘｃｅｌがそれらをフルに使える訳ではなかったかと）し、
http://officetanaka.net/excel/vba/cell/cell09.htm
とかもありますので。

取り敢ずNo.5さんの結果が具体的にどう違うのかが明確にならないと無意味になりそうですしね。
実は順番が入れ替わる箇所があるとかでしょうか？
それともセルの書式設定で表示を変えている物が元に戻って並んでしまう？
画像はダミーでしょうから『見えている物が正しい』とは言えない可能性も考えてみました。

この回答へのお礼

大変申し訳ございません。
添付資料が間違っておりました。。。
皆さんに土下座したいくらい申し訳ないです。
この質問は示させていただき改めて質問いたします。
ご指摘ありがとうございました。

お礼日時：2019/05/12 10:27