エクセルで重複データの内容を右の列に増やす方法

質問

エクセル２００７で、表(1)のようなレコードがあります。
Ｂ列とＣ列の両列をキー列として、両列が次の行と同じ場合、表(2)のように一行にまとめるＶＢＡをどなたかご教示お願いします。
過去ログ等で重複データの行削除は理解できたのですが、キー列が２列の場合や、表(2)のように右の列にデータをどんどん増やす方法がわかりません。
条件は、レコードは1０００行以上、市idと社idは昇順に並んでいるため重複データは必ず上下に連続している、商品の種類は５０以上あり、どれ位右に列が増えるか不明、などです。
ＶＢＡ初心者です。よろしくお願いします。

表(1)（sheet1）
県名｜市id ｜ 社id｜社名｜商品｜空白｜空白・・
秋田｜0001｜0001｜Ａ株｜青大｜空白
秋田｜0001｜0001｜Ａ株｜赤小｜空白
東京｜0002｜0003｜Ｂ株｜黒中｜空白
大阪｜0004｜0001｜Ｃ有｜赤中｜空白
大阪｜0004｜0001｜Ｃ有｜白大｜空白
大阪｜0004｜0002｜Ｄ株｜赤大｜空白
大阪｜0004｜0002｜Ｄ株｜黄中｜空白
大阪｜0004｜0002｜Ｄ株｜緑小｜空白
・
・

表(2)（sheet2）
県名｜市id｜ 社id｜社名｜商品｜商品｜商品・・
秋田｜0001｜0001｜Ａ株｜青大｜赤小｜空白
東京｜0002｜0003｜Ｂ株｜黒中｜空白｜空白
大阪｜0004｜0001｜Ｃ有｜赤中｜白大｜空白
大阪｜0004｜0002｜Ｄ株｜赤大｜黄中｜緑小
・
・

回答No.2

mu2011 · ベストアンサー

一例です。
Sheet1のシートタブ上で右クリック→コードの表示→サンプルコード貼り付け→シート上でAlt＋F8キー押下、sample実行
因みにデータは昇順でなくても問題ありません。（但し、集約はデータ発生順になります）

Sub sample()
Dim i As Long, db, wk, wk1
Set db = CreateObject("Scripting.Dictionary")
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
wk = Cells(i, "A") & " ," & Cells(i, "B") & _
"," & Cells(i, "C") & "," & Cells(i, "D")
db(wk) = db(wk) & " " & Cells(i, "E")
Next
wk = db.keys
With Sheets("sheet2")
.Cells.ClearContents
.Cells(1, 1).Resize(, 4) = Cells(1, 1).Resize(, 4).Value
For i = 0 To UBound(wk)
.Cells(i + 2, "A").Resize(, 4) = Split(wk(i), ",")
wk1 = Split(Trim(db(wk(i))), " ")
.Cells(i + 2, "E").Resize(, UBound(wk1) + 1) = wk1
Next
wk1 = .Cells(1, 1).CurrentRegion.Columns.Count
.Cells(1, "E").Resize(, wk1 - 4) = "商品"
End With
Set db = Nothing
End Sub

お礼

データは昇順でなくてもいいのが、勉強になりました。ありがとうございました。参考にさせていただきます。

回答No.1

tom04

こんばんは！
一例です。

Alt+F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, k As Long, c As Range, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS2.Cells.Clear
With wS1
i = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A:A").Insert
.Rows(1).Copy wS2.Cells(1, 1)
With Range(wS1.Cells(2, 1), wS1.Cells(i, 1))
.Formula = "=C2&""_""&D2"
.Value = .Value
End With
Range(.Cells(1, 1), .Cells(i, 1)).AdvancedFilter Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS2.Cells(1, 1)
.Range("A:A").AutoFilter
.AutoFilterMode = False
For i = 2 To wS2.Cells(Rows.Count, 1).End(xlUp).Row
Set c = .Range("A:A").Find(what:=wS2.Cells(i, 1), LookIn:=xlValues, lookat:=xlWhole)
c.Offset(, 1).Resize(1, 4).Copy wS2.Cells(i, 2)
Next i
For i = 2 To wS2.Cells(Rows.Count, 1).End(xlUp).Row
For k = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(k, 1) = wS2.Cells(i, 1) Then
.Cells(k, 6).Copy wS2.Cells(i, Columns.Count).End(xlToLeft).Offset(, 1)
End If
Next k
Next i
.Range("A:A").Delete
wS2.Range("A:A").Delete
End With
k = wS2.UsedRange.Columns.Count
Range(wS2.Cells(1, 5), wS2.Cells(1, k)) = "商品"
wS2.Cells(1, 1).CurrentRegion.Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub 'この行まで

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