VBAで同じ種類を横並びにする

Question

VBAで、A列、B列の値を取得して、以下のC列、D列の様に出力したいと考えております。

• A列の名前の重複を1つにして、C列に出力する
• B列の値の重複は1つにして、D列に横に並べて出力する

A	B	C	D
鈴木	123	鈴木	123, 456
鈴木	456	加藤	789
鈴木	456	佐藤	100
加藤	789
加藤	789
佐藤	100

ネットで調べながら重複は1つにすることはできました。
ただ、B列の値を横に並べて出力することができません。

以下が私が書いた重複を1つにまとめるまでできたコードですが、私のコードを変更していただいても、
もしくは他に良いコードの書き方などありましたら、ご教示お願い致します。

Sub teratail()

    Dim Dic, i As Integer, name As String
    Dim order_number As Long
    Set Dic = CreateObject("Scripting.Dictionary") 'Key(キー)とItem(データ)をセットで格納して、リストなどを作成するときに使用。Pythonでいうところのたぶん辞書型

    On Error Resume Next
        
        For i = 1 To 10
        
            name = Cells(i, 1).Value '荷受人の列の名前を1つずつ取得
            order_number = Cells(i, 2).Value '注文番号を1つずつ取得
            
            Dic.Add name, order_number ' Dicに追加していく

        Next i
      
        ' 出力
        For i = 0 To Dic.Count - 1
            mykeys = Dic.Keys
            myItems = Dic.Items
            Range("C" & i + 1).Value = mykeys(i)
            Range("D" & i + 1).Value = myItems(i)
        
            'オブジェクトを開放する
            Set Dic = Nothing

        Next i

End Sub

⇒　コードの出力結果

A	B	C	D
鈴木	123	鈴木	123
鈴木	456	加藤	789
鈴木	456	佐藤	100
加藤	789
加藤	789
佐藤	100

Answer 1

InStr関数でアイテム内に同じ値が存在しないのを確認して、追加していけばどうでしょう。

Sub Sample()

    Dim Dic, i As Integer, name As String
    Dim order_number As Long
    Set Dic = CreateObject("Scripting.Dictionary") 'Key(キー)とItem(データ)をセットで格納して、リストなどを作成するときに使用。Pythonでいうところのたぶん辞書型

        
    For i = 1 To 10
        
        name = Cells(i, 1).Value                 '荷受人の列の名前を1つずつ取得
        order_number = Cells(i, 2).Value         '注文番号を1つずつ取得
        If Not Dic.Exists(name) Then
            Dic(name) = order_number
        ElseIf InStr("," & Dic(name) & ",", "," & order_number & ",") = 0 Then
            Dic(name) = Dic(name) & "," & order_number
        End If

    Next i
      
    ' 出力
    Dim myKeys, myItems
    myKeys = Dic.Keys
    myItems = Dic.Items
    With WorksheetFunction
        Range("C1").Resize(Dic.Count).Value = .Transpose(myKeys)
        Range("D1").Resize(Dic.Count).Value = .Transpose(myItems)
    End With
    
    'オブジェクトを開放する
    Set Dic = Nothing

End Sub

Comments

[SatoToy]

どちらのコードも綺麗でとても悩んだのですが、回答が早い順番で選ばせてもらいました。
こういうときに、本当に2つベストアンサーが選べるとか、お礼に投げ銭できるような仕組みがあればと思います。

このような書き方もあるのですね。明日は休みなので、いただいたコードを分解して勉強しようと思います。
ありがとうございました！

Answer 2

とりあえず、今のコードを修正するとすると以下のようになるかと思います。

    Dim Dic, Dic2, i As Integer, name As String
    Dim order_number As Long
    Dim tmp_var As Variant
    Dim tmp_sp() As String
    
    
    Set Dic = CreateObject("Scripting.Dictionary") 'Key(キー)とItem(データ)をセットで格納して、リストなどを作成するときに使用。Pythonでいうところのたぶん辞書型
    Set Dic2 = CreateObject("Scripting.Dictionary") 
    On Error Resume Next
        
    For i = 1 To 10
    
        name = Cells(i, 1).Value '荷受人の列の名前を1つずつ取得
        order_number = Cells(i, 2).Value '注文番号を1つずつ取得
        
        Dic.Add name & vbTab & order_number, "" ' Dicに追加していく
    Next i
    
    
    For Each tmp_var In Dic
        tmp_sp = Split(tmp_var, vbTab)
        If Dic2.Exists(tmp_sp(0)) Then
            Dic2.Item(tmp_sp(0)) = Dic2.Item(tmp_sp(0)) & "," & tmp_sp(1)
        Else
            Dic2.Add tmp_sp(0), tmp_sp(1)
        End If
    Next

    ' 出力
    mykeys = Dic2.Keys
    For i = 0 To Dic2.Count - 1
        Range("C" & i + 1).Value = mykeys(i)
        Range("D" & i + 1).Value = Dic2.Item(mykeys(i))
    Next i
    'オブジェクトを開放する
    Set Dic = Nothing

他のやり方は、例えば
Scripting.DictionaryのItemにScripting.Dictionaryをセットして重複を省いたりするのもいいかもしれないですね。

Comments

[SatoToy]

ありがとうございました！
私のコードの足りないところを補っていただき勉強になります。マクロは全くの初心者で、Pythonを最近少し始めたのですが、こんなに難しいマクロで人の書いたコードの足りないところを補うことができるなんて、ただすごくて尊敬します。
もっと精進しようと思います。ありがとうございました！