Sub ertert()
Dim x, i&, j&, k&, s$
x = Range("A3:E" & Cells(Rows.Count, 1).End(xlUp).Row).Value
With CreateObject("Scripting.Dictionary")
     .CompareMode = 1
     For i = 1 To UBound(x, 1)
         s = x(i, 2) & x(i, 3) & x(i, 4) & x(i, 5)
         If .Exists(s) Then
             k = .Item(s)
             x(k, 1) = x(k, 1) & ", " & x(i, 1)
         Else
             j = j + 1
             x(j, 1) = x(i, 1)
             x(j, 2) = x(i, 2)
             x(j, 3) = x(i, 3)
             x(j, 4) = x(i, 4)
             x(j, 5) = x(i, 5)
             .Item(s) = j
         End If
     Next i
End With

With Range("A3:E" & Cells(Rows.Count, 1).End(xlUp).Row + 2)
     .ClearContents
     .Resize(j).Value = x
End With
End Sub

Sub Collect()
     Dim Dict, key, Arr(), TArr(), i&, j&

     Set Dict = CreateObject("Scripting.Dictionary")
     Arr = [A3:E8].Value
     For i = 1 To UBound(Arr)
          
         key = ""
         For j = 2 To UBound(Arr, 2)
             key = key & Arr(i, j)
         Next j
         If Dict.exists(key) Then
             TArr = Dict(key)
             TArr(1) = TArr(1) & ", " & Arr(i, 1)
             Dict(key) = TArr
         Else
             ReDim TArr(1 To UBound(Arr, 2))
             For j = 1 To UBound(Arr, 2)
                 TArr(j) = Arr(i, j)
             Next j
             Dict.Add key, TArr
         End If
     Next i
     ReDim Arr(1 To Dict.Count, 1 To UBound(Arr, 2))
     i = 1
     For Each key In Dict.keys
         TArr = Dict(key)
         For j = 1 To UBound(TArr)
             Arr(i, j) = TArr(j)
         Next j
         i = i + 1
     Next key
      
     Range("A14", Range("A14").Offset(UBound(Arr) - 1, UBound(Arr, 2) - 1).Address).Value = Arr
      
End Sub