Fusionner les doublons

Sub ListeSansDoublons()
   Set mondico = CreateObject("Scripting.Dictionary")
   Set mondico2 = CreateObject("Scripting.Dictionary")
   For Each c In Range("c2", [c65000].End(xlUp))
     If Not mondico.exists(c.Value) Then
        mondico(c.Value) = c.Offset(, -1).Value
        mondico2(c.Value) = c.Offset(, -2).Value
     Else
        mondico(c.Value) = mondico(c.Value) & "," & c.Offset(, -1).Value
     End If
  Next c
  i = 2
  For Each c In mondico.keys
    Cells(i, "i") = c
    Cells(i, "h") = mondico(c)
    Cells(i, "g") = mondico2(c)
    i = i + 1
  Next c
End Sub

Sub es()
  Dim t(), i As Long, x As Long, m As Object, z
   Set m = CreateObject("Scripting.Dictionary")
   t = Range("a2:c" & Cells(Rows.Count, 1).End(3).Row)
   For i = 1 To UBound(t)
    z = t(i, 3)
   If m.exists(z) Then
    t(m(z), 2) = t(m(z), 2) & " , " & t(i, 2)
    Else
    x = x + 1
    t(x, 1) = t(i, 1): t(x, 2) = t(i, 2): t(x, 3) = t(i, 3)
    m(z) = x
    End If
    Next i
    [e2].Resize(x, 3) = t
 End Sub