XL 2010 Concatener selon valeurs

Sub test()
Dim t, d, i&, s
t = Range("a4:b" & Cells(Rows.Count, "a").End(xlUp).Row)
Set d = CreateObject("scripting.dictionary")
d.comparemode = vbTextCompare
For i = 1 To UBound(t)
  If Not d.exists(t(i, 1)) Then
    d.Add t(i, 1), t(i, 2)
  Else
    s = d(t(i, 1))
    s = s & ", " & t(i, 2)
    d(t(i, 1)) = s
  End If
Next i
For i = 1 To UBound(t)
  s = d(t(i, 1))
  t(i, 2) = s
  t(i, 1) = UBound(Split(s, ",")) + 1
Next i
Range("c4").Resize(UBound(t), 2) = t
Range("a:d").EntireColumn.AutoFit
End Sub

Sub test()
Dim t, d, i&, s, xcompte
t = Range("a4:b" & Cells(Rows.Count, "a").End(xlUp).Row)
Set d = CreateObject("scripting.dictionary")
d.comparemode = vbTextCompare
For i = 1 To UBound(t)
  If Not d.exists(t(i, 1)) Then
    d.Add t(i, 1), CreateObject("scripting.dictionary")
    d(t(i, 1)).comparemode = vbTextCompare
  End If
  If Not d(t(i, 1)).exists(t(i, 2)) Then d(t(i, 1)).Add t(i, 2), ""
Next i

For i = 1 To UBound(t)
  t(i, 2) = Join(d(t(i, 1)).keys(), ",")
  t(i, 1) = d(t(i, 1)).Count
Next i

Range("c3:d" & Cells(Rows.Count, "c").End(xlUp).Row).Offset(1).ClearContents
Range("c4").Resize(UBound(t), 2) = t
Range("a:d").EntireColumn.AutoFit
End Sub