Sub test()
Dim diconodoublon, list_unique(), elem, i&
Set diconodoublon = CreateObject("scripting.dictionary")
Set plage = Range("b2:b" & Cells(Rows.Count, "b").End(xlUp).Row)
For i = plage.Row To plage.Row + plage.Rows.Count - 1
If Not diconodoublon.exists(Cells(i, "b").Text) Then
diconodoublon(Cells(i, "b").Text) = Cells(i, "A").Text
Else
diconodoublon(Cells(i, "b").Text) = diconodoublon(Cells(i, "b").Text) & "toto"
End If
Next
For Each elem In diconodoublon
If Not diconodoublon(elem) Like "*toto*" Then x = x + 1: ReDim Preserve list_unique(1 To x): list_unique(x) = elem
diconodoublon(elem) = Replace(diconodoublon(elem), "toto", "")
Next
Cells(2, "c").Resize(diconodoublon.Count, 1) = Application.Transpose(diconodoublon.items)
Cells(2, "d").Resize(diconodoublon.Count, 1) = Application.Transpose(diconodoublon.keys)
Cells(2, "e").Resize(UBound(list_unique), 1) = Application.Transpose(list_unique)
End Sub