Sub ListeSansDoublons()
Dim tablo, i&, i0&, i1&, dico As New Dictionary, s$, xkey, t As Single
t = Timer()
Application.ScreenUpdating = False
tablo = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
Range("e2:f" & Rows.Count).ClearContents
i0 = LBound(tablo): i1 = UBound(tablo)
For i = i0 To i1
s = tablo(i, 2) & "}"
If dico.Exists(tablo(i, 1)) Then
If InStr(dico(tablo(i, 1)), s) = 0 Then dico(tablo(i, 1)) = dico(tablo(i, 1)) & s
Else
dico(tablo(i, 1)) = s
End If
Next i
For Each xkey In dico.Keys
dico(xkey) = UBound(Split(dico(xkey), "}"))
Next xkey
Range("e2").Resize(dico.Count) = Application.Transpose(dico.Keys)
Range("f2").Resize(dico.Count) = Application.Transpose(dico.Items)
Application.ScreenUpdating = True
MsgBox Format(Timer() - t, "0.000") & " secondes"
End Sub