Try this code
Sub Test()
    Dim a, v, i As Long, c As Integer

    c = 5   'Column E
    a = Range("A3:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value

    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = LBound(a) To UBound(a)
            If .Exists(a(i, 2)) Then
                .Item(a(i, 2)) = .Item(a(i, 2)) & Chr(2) & a(i, 1)
            Else
                .Item(a(i, 2)) = a(i, 2) & Chr(2) & a(i, 1)
            End If
        Next i

        Application.ScreenUpdating = False
            For Each v In .Items
                Cells(2, c).Resize(UBound(Split(v, Chr(2))) + 1).Value = Application.Transpose(Split(v, Chr(2)))
                c = c + 1
            Next v
        Application.ScreenUpdating = True
    End With
End Sub
Similar issue at this link
https://www.excelforum.com/excel-pro...sheet-2-a.html