Sub ertert()
Dim x, y(), i&, j&, k&
With Sheets("отчёт")
     x = .Range("AF5:AH" & .Cells(Rows.Count, "AF").End(xlUp).Row).Value
End With
ReDim y(1 To UBound(x), 1 To 3)
With CreateObject("Scripting.Dictionary")
     .CompareMode = 1
     For i = 1 To UBound(x)
         If .Exists(x(i, 1)) Then
             k = .Item(x(i, 1))
             If InStr(y(k, 2), x(i, 2)) = 0 Then y(k, 2) = y(k, 2) & ", " & x(i, 2)
             y(k, 3) = y(k, 3) & ", " & x(i, 3)
         Else
             j = j + 1: .Item(x(i, 1)) = j
             y(j, 1) = x(i, 1)
             y(j, 2) = x(i, 2)
             y(j, 3) = x(i, 3)
         End If
     Next i
End With
Sheets("Лист1").Range("A2:C2").Resize(j) = y
End Sub