Fusionner les doublons

[houkmellah]

Bonjour tous le monde,

Je viens vers vous pour la demande d'une solution qui permette de fusionner les cellules doublons pour les cellules mitoyennes qui comportent différentes valeurs je souhaite regrouper toutes les valeurs dans une cellule.


Ci-joint un fichier qui explique concrètement mon cas.


Je reste disponible pour tout information complémentaire.


Cordialement,

Taha.

 

[BOISGONTIER]

Re : Fusionner les doublons

Bonjour,

cf pj

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

JB

 

[laetitia90]

Re : Fusionner les doublons

bonjour

une facon d'ecrire en passant par un "tablo" + 1 dico

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

 

[houkmellah]

Re : Fusionner les doublons

Bonjour BOISGONTIER et laetitia,


Je vous remercie pour votre réponse, la solution que vous m'avez proposé marche à merveille .

 

[gosselien]

Re : Fusionner les doublons

bonjour,

2 solution de dépannage mais en XL 2007

P.