エクセルのマクロ記述方法について教えてください。

質問

シート１に個人別商品購入状況リストがあります。　全データは50000行くらいです。商品は10種類ですが、各人の購入商品の種類はまちまちです。
≪シート１≫
A列　　　B列　　　C列　　　　　D列
氏名　　商品NO　購入個数　 店舗
－－－－－－－－－－－－－－－－－－－－－－
NNN　１０１　　 　３４５　 　　大阪
　　　 １０３　　　　 ５６　　　　山口
　　　　１０８　　　　 ４５　　　富山　　　　　
　　　　１２０　 　 １２３　　　　 秋田
BBB 　１０３ 　 　　５１ 　　　東京
　　　　１２５ 　　　 ６９ 　　 　 横浜
UUU 　１０１ 　　１３４ 　 　 和歌山
　 　　 １０６ 　　　 ７８ 　　 　 大阪
　　　 　１１０ 　　 ２３９ 　　 　 神戸

このデータをシート２に、1名1行となるよう転記します。
≪シート２≫
A列　　　B列　　　　C列　　　　　D列 　 　 E列　　　　　F列　　　　　G列　・・・
氏名　　　商品101 店舗 　　 商品103 　 店舗 　　 商品106 　　 店舗
　　　　　 購入個数 　　　　 　 購入個数　　　　　　　購入個数
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
NNN　 　345　　　　 大阪　　　　　　56　　　山口
BBB　　　　　　　　　　　　　　　　　　51 　　　東京
UUU　　　134 　　 和歌山　　　　　　　　　　　　　　　　　　　 78 　　 大阪

氏名が同じである間は商品番号の一致するデータのセルの値を取得して転記する、氏名が異なる場合はその氏名をA列にインプットし、・・という作業の繰り返しでしょうか。
if then
elseif then
として条件分岐し、loopで繰り返すという記述をすればよいかと思うのですが、考え方はあっていますでしょうか？　お知恵を拝借できればありがたいです。

回答No.2

tom04 · ベストアンサー

No.1です！

同じ人が同じ商品を別店舗で購入する場合がある場合もあるというコトですので・・・

この場合は表の表示方法を工夫する必要があると思います。
そこで、↓の画像のように同一商品でも購入店舗が異なる場合は
行を追加して表示するようにしてみました。

尚、今回も制約があります。
同一人物で購入店舗は複数出ても構いませんが、
同じ人で商品・店舗が重複していない！
すなわち、仮に
NNNさんが商品「101」を店舗「大阪」で購入した場合は
同じデータは1行しかない！という前提です。
もう一度コードを載せてみます。

※　前半部分は前回と一緒で、後半だけ手を加えてみました。

Sub test2() 'この行から
Dim i As Long, j As Long, k As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
ws2.Cells.ClearContents
ws1.Columns("A:D").Copy Destination:=ws3.Cells(1, 4)
ws3.Columns(5).Copy ws3.Cells(1, 3)
ws3.Activate
i = ws3.Cells(Rows.Count, 3).End(xlUp).Row
Range(ws3.Cells(2, 1), ws3.Cells(i, 1)).Formula = "=IF(D2="""",A1,D2)"
ws3.Columns(1).Copy
ws3.Cells(1, 4).Select
Selection.PasteSpecial Paste:=xlValues
Range(ws3.Cells(2, 2), ws3.Cells(i, 2)).Formula = "=IF(COUNTIF(E$2:E2,E2)=1,E2,"""")"
ws3.Columns(2).Copy
ws3.Cells(1, 2).Select
Selection.PasteSpecial Paste:=xlValues
Range(ws3.Cells(2, 1), ws3.Cells(i, 1)).Formula = "=IF(B2="""",2,1)"
ws3.Columns(1).Copy
ws3.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlValues
Range(ws3.Cells(2, 1), ws3.Cells(i, 2)).Sort key1:=ws3.Cells(1, 1), order1:=xlAscending
ws3.Columns(2).Sort key1:=ws3.Cells(1, 2), order1:=xlAscending
ws2.Cells(1, 1) = "氏名"
For k = 1 To ws3.Cells(Rows.Count, 2).End(xlUp).Row
If WorksheetFunction.CountIf(ws2.Rows(1), ws3.Cells(k, 2)) = 0 Then
With ws2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
.Value = ws3.Cells(k, 2)
.NumberFormatLocal = """商""""品""0"
.Offset(, 1) = "店舗"
End With
End If
Next k
ws2.Rows(1).HorizontalAlignment = xlCenter
For k = 2 To ws3.Cells(Rows.Count, 4).End(xlUp).Row
If WorksheetFunction.CountIf(ws2.Columns(1), ws3.Cells(k, 4)) = 0 Then
ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1) = ws3.Cells(k, 4)
End If
i = WorksheetFunction.Match(ws3.Cells(k, 4), ws2.Columns(1), False)
j = WorksheetFunction.Match(ws3.Cells(k, 5), ws2.Rows(1), False)
If ws2.Cells(i, j + 1) = "" Or ws2.Cells(i, j + 1) = ws3.Cells(k, 7) Then
With ws2.Cells(i, j)
.Value = ws2.Cells(i, j) + ws3.Cells(k, 6)
.Offset(, 1) = ws3.Cells(k, 7)
End With
ElseIf ws2.Cells(1, j) = ws3.Cells(k, 3) And ws2.Cells(i, j) <> ws3.Cells(k, 7) Then
ws2.Rows(i + 1).Insert
ws2.Cells(i + 1, 1) = ws3.Cells(k, 4)
With ws2.Cells(i + 1, j)
.Value = ws3.Cells(k, 6)
.Offset(, 1) = ws3.Cells(k, 7)
End With
End If

Next k
ws3.Cells.Clear
ws2.Columns.AutoFit
Application.ScreenUpdating = True
ws2.Activate
ws2.Cells(1, 1).Select
End Sub 'この行まで

※　今回もじっくり「我慢の子」でPCの前で待ってみてください。
※　詳しく検証していませんので、ご希望通りにならなかったらごめんなさいね。m(_ _)m

お礼

さっそく要望におこたえいただき、ありがとうございます！
このマクロを動かしてみましたが、うまくいきそうです。さいわい「同一人物で異なる店舗」のデータ数が限られているので、リスト完成後に2行データを検索して合体させればいいですね。
劇的に操作が簡単になりました。
重ねて、ありがとうございました！！

回答No.1

tom04

こんばんは！
Sheet1のデータは2行目以降にあるとします。

前提条件として
同一人物が商品を購入する場合、必ず同じ店舗での購入！とします。
（同一人物で複数行に同じ商品があっても構いませんが、必ず同じ店舗での購入）
尚、Sheet3を作業用のSheetとして使用していますので、Sheet3は全く使用していない！とします。

Alt＋F11キー　→　画面左側の「This Workbook」をダブルクリック　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i As Long, j As Long, k As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
ws2.Cells.ClearContents
ws1.Columns("A:D").Copy Destination:=ws3.Cells(1, 4)
ws3.Columns(5).Copy ws3.Cells(1, 3)
ws3.Activate
i = ws3.Cells(Rows.Count, 3).End(xlUp).Row
Range(ws3.Cells(2, 1), ws3.Cells(i, 1)).Formula = "=IF(D2="""",A1,D2)"
ws3.Columns(1).Copy
ws3.Cells(1, 4).Select
Selection.PasteSpecial Paste:=xlValues
Range(ws3.Cells(2, 2), ws3.Cells(i, 2)).Formula = "=IF(COUNTIF(E$2:E2,E2)=1,E2,"""")"
ws3.Columns(2).Copy
ws3.Cells(1, 2).Select
Selection.PasteSpecial Paste:=xlValues
Range(ws3.Cells(2, 1), ws3.Cells(i, 1)).Formula = "=IF(B2="""",2,1)"
ws3.Columns(1).Copy
ws3.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlValues
Range(ws3.Cells(2, 1), ws3.Cells(i, 2)).Sort key1:=ws3.Cells(1, 1), order1:=xlAscending
ws3.Columns(2).Sort key1:=ws3.Cells(1, 2), order1:=xlAscending
ws2.Cells(1, 1) = "氏名"
For k = 1 To ws3.Cells(Rows.Count, 2).End(xlUp).Row
If WorksheetFunction.CountIf(ws2.Rows(1), ws3.Cells(k, 2)) = 0 Then
With ws2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
.Value = ws3.Cells(k, 2)
.NumberFormatLocal = """商""""品""0"
.Offset(, 1) = "店舗"
End With
End If
Next k
ws2.Rows(1).HorizontalAlignment = xlCenter
For k = 2 To ws3.Cells(Rows.Count, 4).End(xlUp).Row
If WorksheetFunction.CountIf(ws2.Columns(1), ws3.Cells(k, 4)) = 0 Then
ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1) = ws3.Cells(k, 4)
End If
i = WorksheetFunction.Match(ws3.Cells(k, 4), ws2.Columns(1), False)
j = WorksheetFunction.Match(ws3.Cells(k, 5), ws2.Rows(1), False)
With ws2.Cells(i, j)
.Value = ws2.Cells(i, j) + ws3.Cells(k, 6)
.Offset(, 1) = ws3.Cells(k, 7)
End With
Next k
ws3.Cells.Clear
ws2.Columns.AutoFit
Application.ScreenUpdating = True
ws2.Activate
ws2.Cells(1, 1).Select
End Sub 'この行まで

※　データが5万行程度あるというコトなので、かなりの時間を要します。
PCの前で腕組みしてじっくり待ってください。m(_ _)m

お礼

tomさん、早速ありがとうございます。素晴らしいです！試してみたらちゃんと処理できました！

　ただ、前提条件の店舗については、必ずしも常に同じ店舗とは限らないので、その場合は一旦準備として、購入個数と店舗のセルを"＆"で繋げて、一つのセルにまとめ、マクロ処理した後で分離する、という作業をやればいいでしょうか？