[VBA] 一致した条件の項目を1行にまとめる

質問

こちらの識者の方々にはいつもお世話になっています。
VBAの質問です。

環境は下記になります。
OS=windows7 pro 64bit
Office=Excel2010(14.0.7128.5000)

・やりたいこと
下図の左側のようなリストがあります。
荷物を一つずつ記載したリストなのですが、番号、コンテナが一致している荷物については右側の図のようにカンマ区切りで1行に纏めたいです。
この場合、どのようなコードが適していますでしょうか？

質問に不備不足等ございましたらご指摘ください。
ご面倒お掛けしますがよろしくお願いします。

回答No.3

ushi2015 · ベストアンサー

こんにちは
Sub test1()
　　Dim q As Range
　　Dim d As Object
　　Dim r As Range
　　Dim w As String
　　Dim v()

　　Set q = Range("A1").CurrentRegion.Columns(1).Cells
　　Set d = CreateObject("Scripting.Dictionary")

　　If q.Count = 1 Then Exit Sub

　　For Each r In q
　　　　If r.Row > 1 Then
　　　　　　w = r.Value & "," & r.Offset(, 1).Value
　　　　　　If Not d.exists(w) Then
　　　　　　　　d(w) = r.Offset(, 2).Value
　　　　　　Else
　　　　　　　　d(w) = d(w) & "," & r.Offset(, 2).Value
　　　　　　End If
　　　　End If
　　Next
　　Application.ScreenUpdating = False
　　Range("E2").Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
　　Range("E2").Resize(d.Count, 1).TextToColumns Destination:=Range("E2"), DataType:=xlDelimited, _
　　　　TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
　　　　Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
　　　　:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
　　Range("G2").Resize(d.Count) = WorksheetFunction.Transpose(d.Items)
　　Application.ScreenUpdating = True
End Sub
こんな感じも。

お礼

連想配列を使う方法ですね。
できました！
ありがとうございます。

回答No.2

chie65536（@chie65535）

Option base 1

Sub Macro1()
'変数の定義
Dim last As Long
Dim i As Long, j As Long
Dim n As Variant, m As Variant

'最下行を求めてlastに代入
last = Range("A1").End(xlDown).Row

'必要なだけの配列を用意
ReDim ary(last) As Variant
ReDim item(last) As Variant

’配列に２～最下行のデータを格納
For i = 2 To last
ary(i) = Cells(i, 1) & "#" & Cells(i, 2)
item(i) = Cells(i, 3)
Next

’番号とコンテナを連結した値でソート
For i = 2 To last - 1
For j = i + 1 To last
If ary(i) > ary(j) Then
n = ary(i)
ary(i) = ary(j)
ary(j) = n
n = item(i)
item(i) = item(j)
item(j) = n
End If
Next
Next

’E列～G列に結果を代入
m = ary(2)
n = item(2)
j = 2
For i = 3 To last
If m <> ary(i) Then
Cells(j, 5) = Left(m, InStr(1, m, "#") - 1)
Cells(j, 6) = Mid(m, InStr(1, m, "#") + 1, Len(m))
Cells(j, 7) = n
m = ary(i)
n = item(i)
j = j + 1
Else
n = n & "," & item(i)
End If
Next
Cells(j, 5) = Left(m, InStr(1, m, "#") - 1)
Cells(j, 6) = Mid(m, InStr(1, m, "#") + 1, Len(m))
Cells(j, 7) = n

End Sub

お礼

できました！
ありがとうございます。

回答No.1

ushi2015

こんにちは
Sub test()
　　Dim q As Range
　　Dim r As Range
　　Dim s As Range
　　Dim t As Range
　　Dim w As String

　　Columns("A:B").AdvancedFilter _
　　　　Action:=xlFilterCopy, _
　　　　CopyToRange:=Range("E1:F1"), _
　　　　Unique:=True

　　Set q = Range("E1").CurrentRegion.Columns(1).Cells

　　If q.Count = 1 Then Exit Sub

　　Application.ScreenUpdating = False

　　For Each r In q
　　　　If r.Row > 1 Then
　　　　　　Range("A1").CurrentRegion.AutoFilter 1, r.Value
　　　　　　Range("A1").CurrentRegion.AutoFilter 2, r.Offset(, 1).Value
　　　　　　Set s = Range("A1").CurrentRegion.Columns(3) _
　　　　　　　　.SpecialCells(xlCellTypeVisible)
　　　　　　For Each t In s
　　　　　　　　If t.Row > 1 Then
　　　　　　　　　　If w = "" Then
　　　　　　　　　　　　w = t.Value
　　　　　　　　　　Else
　　　　　　　　　　　　w = w & "," & t.Value
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　Next
　　　　　　r.Offset(, 2) = w
　　　　　　w = ""
　　　　End If
　　Next
　　If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
　　Application.ScreenUpdating = True
End Sub
こんな感じですか？

お礼

できました！
ありがとうございます。