重複するidをデータごとにまとめるvbaのコード

質問

excel　vbaで次のようなコードを作りたいです。
シート1に元データが4000件ほどあります。
シート2に、シート1のidが同じものを、3行ずつ横に表示したいです。
idと名前は1度のみ、それ以降は都道府県名と数字のみ表示します。

同じidを持つものが3行に満たないのであれば、改行します。
同じidを持つものが3行以上ある場合は、3行ごとに改行します。

1　佐藤　東京　1000
1　佐藤　千葉　2100
1　佐藤　青森　1300
2　鈴木　東京　5600
2　鈴木　千葉　3500
3　山田　三重　2910
3　山田　長野　3820
3　山田　山口　8760
3　山田　沖縄　6560
4
：

↓

1　佐藤　東京　1000　千葉　2100　青森　1300
2　鈴木　東京　5600　千葉　3500
3　山田　三重　2910　長野　3820　山口　8760
3　山田　沖縄　6560
4
：

どなたかこのような動作を行うvbaのコードを教えてください。
よろしくお願いします。

回答No.1

eden3616 · ベストアンサー

(1)Alt+F11でVBEを開き、挿入→標準モジュール
(2)作成された標準モジュールへ以下のVBAコードを貼付
(3)コード内の以下の箇所を該当のシート名に合わせて修正
　　　'対象のシートを設定
　　　Set mySt(0) = Worksheets("Sheet1")　←元データのシート
　　　Set mySt(1) = Worksheets("Sheet2")　←表示先のシート
(4)Alt+F11でVBEを閉じ、Alt+F8で「sample」マクロを実行

※補足
処理中で使用している区切り文字列について

元データのA列（ID）に「;」「,」を含む場合は正常に動作しません。
含む可能性がある場合は、コード内の以下の箇所をそれぞれ元データで使用していない
文字列に変更してください。（key(0)とkey(1)は別の文字列としてください）
　　　key(0) = ";": key(1) = ","

■VBAコード

Sub sample()
'変数を宣言
Dim mySt(1) As Worksheet, key(1) As String
Dim bsData() As Variant, myData() As Variant
Dim i As Long, j As Long, cnt As Long
Dim names() As String, buf As Variant
Dim tar As Range, flag As Boolean

'対象のシートを設定
Set mySt(0) = Worksheets("Sheet1")
Set mySt(1) = Worksheets("Sheet2")

'区切り文字（必要であれば変更）
key(0) = ";": key(1) = ","

'配列にデータを格納
With mySt(0)
　　bsData = .Range(.Cells(1, "A"), .Cells(Rows.Count, "C").End(xlUp))
End With

'重複しない名前の配列を作成
For i = 1 To UBound(bsData, 1)
　　flag = True
　　If Sgn(names) <> 0 Then
　　　　For j = 0 To UBound(names, 2)
　　　　　　If names(0, j) = bsData(i, 1) Then
　　　　　　　　flag = False
　　　　　　　　Exit For
　　　　　　End If
　　　　Next j
　　End If
　　If flag Then
　　　　If Sgn(names) = 0 Then
　　　　　　ReDim names(1, 1)
　　　　Else
　　　　　　ReDim Preserve names(1, UBound(names, 2) + 1)
　　　　End If
　　　　names(0, UBound(names, 2)) = bsData(i, 1)
　　End If
Next i

'名前配列へ同名のデータを集約
For i = 1 To UBound(names, 2)
　　For j = 1 To UBound(bsData, 1)
　　　　If bsData(j, 1) = names(0, i) Then
　　　　　　names(1, i) = names(1, i) & bsData(j, 2) & key(1) & bsData(j, 3) & key(0)
　　　　End If
　　Next j
Next i

'シートへ書き出し
Application.ScreenUpdating = False
With mySt(1)
　　.Cells.ClearContents
　　For i = 1 To UBound(names, 2)
　　　　buf = Split(names(1, i), key(0))
　　　　For j = 0 To UBound(buf) - 1
　　　　　　If j Mod 3 = 0 Then
　　　　　　　　cnt = cnt + 1
　　　　　　　　Set tar = .Cells(cnt, "A")
　　　　　　　　tar = names(0, i)
　　　　　　End If
　　　　　　tar.Offset(0, (j Mod 3) * 2 + 1) = Left(buf(j), InStr(1, buf(j), key(1)) - 1)
　　　　　　tar.Offset(0, (j Mod 3) * 2 + 2) = Right(buf(j), Len(buf(j)) - InStr(1, buf(j), key(1)))
　　　　Next j
　　Next i
End With
Application.ScreenUpdating = True

'終了
MsgBox "終了"
End Sub

お礼

完璧です！
本当にありがとうございました！！