x = Cells(s, "I") & Cells(i, "B") & ", "
Cells(s, "I") = Left$(x , len(x) - 2)

Sub qqqr()
  Dim s&, i&, n
  Dim A&, B$, C&, D#, E#, F#
  s = 2
  n = Cells(2, "C")
  ps = Range("A" & Rows.Count).End(xlUp).Row + 1
  Application.ScreenUpdating = False
  For i = 2 To ps
    If Cells(i, "C") <> n Then
      Cells(s, "A") = A
      Cells(s, "C") = C
      Cells(s, "D") = D
      Cells(s, "E") = E
      Cells(s, "F") = F
      B = Left$(B, Len(B) - 2)
      If Len(B) > Columns("B:B").ColumnWidth Then Columns("B:B").ColumnWidth = Len(B) - 3
      Cells(s, "B") = B
      A = 0: B = "": C = 0: D = 0: E = 0: F = 0
      n = Cells(i, "C")
      s = s + 1
      i = i - 1
    Else
      A = Cells(i, "A")
      B = B & Cells(i, "B") & ", "
      C = Cells(i, "C")
      D = Cells(i, "D")
      E = Cells(i, "E")
      F = F + Cells(i, "F")
    End If
  Next
  Range(Cells(s, "A"), Cells(ps, "F")).ClearContents
  Application.ScreenUpdating = True
End Sub

Dim A$, B$, C$, D$, E$, F#

A = "": B = "": C = "": D = "": E = "": F = 0