How do I output the same type of value in VBA next to the same value?

Question

I want to use VBA to get the values of columns A and B and output them to columns C and D as below.

1. Same names in column A are made into one and output to column C.
2. Same values in column B are kept as one and output side by side in column D.

A	B	C	D
Suzuki	123	Suzuki	123, 456
Suzuki	456	Kato	789
Suzuki	456	SAto	100
Kato	789
Kato	789
SAto	100

I'm able to get the same value to one with researching on the internet. However, I'm unable to output the values in column B side by side.

Here is the code I made myself to combine the same values into one. Please let me know if you can modify my code or if you have a better way to write the code.

VBA

Sub sample()

    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

↓ My code output

A	B	C	D
Suzuki	123	Suzuki	123
Suzuki	456	Kato	789
Suzuki	456	Sato	100
Kato	789
Kato	789
Sato	100

Answer 1

You only ever call Add on the dictionary - you need to check to see if the dictionary already has name as a key, and either Add a new key or update the existing value.

Try this:

Sub sample()
    Dim dic As Object, i As Long, name As String, ws As Worksheet
    Dim order_number As Long
    
    Set dic = CreateObject("Scripting.Dictionary")
    Set ws = ActiveSheet
    'loop all rows of data
    For i = 1 To ws.Cells(Rows.Count, "A").End(xlUp).Row
        name = Cells(i, 1).Value
        order_number = Cells(i, 2).Value
        If Not dic.exists(name) Then                       'new key?
            dic.Add name, order_number                     'add key and first value
        Else
            dic(name) = dic(name) & "," & order_number     'concatenate new value
        End If
    Next i
    
    DictToRange dic, ws.Range("D1")
    
    'no need to set locally-declared onjects to Nothing...
End Sub

'write keys and values from Dictionary `dic`, starting at `StartCell`
Sub DictToRange(dic As Object, StartCell As Range)
    Dim k, i
    i = 0
    For Each k In dic
        StartCell.Offset(i).Resize(1, 2).Value = Array(k, dic(k))
        i = i + 1
    Next k
End Sub