=ЕСЛИ(A2=A3;B2&";"&C3;B2)

Option Explicit

Sub Dictionary_Coll()
'  Справочный материал: https://www.osp.ru/winitpro/2006/07/3643019/
                       'http://perfect-excel.ru/publ/excel/makrosy_i_programmy_vba/ischerpyvajushhee_opisanie_obekta_dictionary/7-1-0-101
    Dim MyArray(), Dic As Object, a As Range
    
''   для раннего связывания требуется подключение
''   Tools - References... "Microsoft Scripting Runtime"
'    Set Dic = New Dictionary
    
    Set Dic = CreateObject("Scripting.Dictionary")
    On Error Resume Next    'что бы не останавливалось на ошибке
    
    For Each a In ActiveSheet.Range("a2:a13")
        If Dic.Exists(CStr(a)) Then 'Проверить наличие ключа
            Dic.Item(CStr(a)) = Dic.Item(CStr(a)) & "," & a.Offset(, 1).Value
        Else
            Dic.Add CStr(a), a.Offset(, 1).Value                    'добавление
'                    [ключ], [значение]
        End If
    Next a
    
    MyArray = Application.Transpose(Array(Dic.Keys, Dic.Items))
    
    With Worksheets.Add 'выводим на лист
        .Range(.Cells(1, 1), .Cells(UBound(MyArray, 1), UBound(MyArray, 2))) = MyArray
    End With
End Sub

Sub tt()
    c_ = 1
    r0_ = 1
    n_ = Cells(Rows.Count, c_).End(3).Row - r0_ + 1
    ar = Cells(r0_, c_).Resize(n_, 2)
    Set slov = CreateObject("Scripting.Dictionary")
    With slov
        For i = 1 To n_
            If ar(i, 2) <> "" And ar(i, 2) <> "null" Then
                .Item(ar(i, 1)) = .Item(ar(i, 1)) & IIf(.exists(ar(i, 1)), ",", "") & ar(i, 2)
            End If
        Next i
        Sheets.Add
        Cells(1).Resize(.Count) = Application.Transpose(.Keys)
        Cells(2).Resize(.Count) = Application.Transpose(.items)
    End With
End Sub