Sub Main()
Dim r As Range
Set r = Selection
Dim a As Variant
a = r
Dim y As Long
Dim x As Integer
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
For y = 1 To UBound(a, 1)
For x = 2 To UBound(a, 2)
If Not IsEmpty(a(y, x)) Then
If Not dic.Exists(a(y, x)) Then Set dic.Item(a(y, x)) = CreateObject("Scripting.Dictionary")
dic.Item(a(y, x)).Item(a(y, 1)) = 0
End If
Next
Next
ReDim a(1 To dic.Count, 1 To 2)
For y = 1 To dic.Count
a(y, 1) = dic.Keys()(y - 1)
a(y, 2) = Join(dic.Items()(y - 1).Keys(), ",")
Next
r.Cells(r.Rows.Count + 2, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub