Concaténer des valeurs uniques selon des valeurs uniques

Le 13/05/2016 à 02:16

Bonjour à tous,

Je dispose d'un fichier qui se présente sous cette forme :

NOM_PROP | CDE

M MACHIN | Le Ruisseau

M TRUQUE | Le Ru

M DURAND | La Rivière

M DURAND | La Fausse Rivière

Mme DUBOIS | Le Bief

Mme DUBOIS | Le Bief

M DUPONT | Le Bief

M DUPONT | Le Bief

Mme CHELOUX | Le Ru

Mme CHELOUX | Le Ru

Mme CHELOUX | Le Ruisseau

Mme CHELOUX | La Fausse Rivière

Et je souhaite obtenir un tableau avec en colonne A la liste des valeurs uniques de NOM_PROP, et en colonne B une concaténation des valeurs uniques correspondantes de CDE séparées par une virgule et un espace, comme suit :

NOM_PROP | CDE |

M MACHIN | Le Ruisseau |

M TRUQUE | Le Ru |

M DURAND | La Rivière, La Fausse Rivière |

Mme DUBOIS | Le Bief |

M DUPONT | Le Bief |

Mme CHELOUX | Le Ru, Le Ruisseau, La Fausse Rivière |

Le TCD ne permettant pas de manipuler du texte (et c'est bien dommage), je me tourne vers la communauté du forum afin d'éclairer ma lanterne par une macro (probable) ou du VBA.

Afin d'illustrer cela, je vous joins un fichier exemple où j'ai remplacé les noms des propriétaires par des numéros :

30exemple-propcde.xlsx (151.58 Ko)

Ce qui devra du coup donner quelque chose de la forme suivante :

NOM_PROP | CDE |

1 | Le Ruisseau |

2 | Le Ru |

3 | La Rivière, La Fausse Rivière |

4 | Le Bief |

5 | Le Bief |

6 | Le Ru, Le Ruisseau, La Fausse Rivière |

En vous remerciant d'avance de vos réponses.

Bien cordialement,

Le 13/05/2016 à 07:55

Re-bonjour à tous,

Je me permets d'ajouter, en plus de ma première demande, une deuxième variante. En effet, je souhaiterais également pouvoir, au lieu de concaténer toutes les valeurs uniques en colonne B, les répartir dans autant de colonnes qu'il y a de CDE correspondant à un même NOM_PROP, afin d'obtenir le résultat suivant :

NOM_PROP | CDE_1 | CDE_2 | CDE_3 | ...

M MACHIN | Le Ruisseau | | | ...

M TRUQUE | Le Ru | | | ...

M DURAND | La Rivière | La Fausse Rivière | | ...

Mme DUBOIS | Le Bief | | | ...

M DUPONT | Le Bief | | | ...

Mme CHELOUX | Le Ru | Le Ruisseau | La Fausse Rivière | ...

En vous remerciant d'avance de vos propositions.

Bien cordialement,

Le 13/05/2016 à 08:47

Bonjour,

Mauvaise idée de mettre un nombre pour représenter un nom (texte)...

Cordialement.

Le 13/05/2016 à 08:51

Bonjour,

Le but n'étant pas de l'utiliser tel quel, mais de vous apporter une illustration du tableau en "masquant" les noms des propriétaires.

Bien cordialement,

Le 13/05/2016 à 08:58

Tu n'as apparemment pas conscience de l'attention à accorder à la notion de type de données...

Bonne journée.

Le 13/05/2016 à 09:10

Bonjour,

Un essai :

Sub Galopin()
   Set mondico = CreateObject("Scripting.Dictionary")
   a = Range("A2:A" & [A65000].End(xlUp).Row)
   For i = LBound(a) To UBound(a)
     mondico(a(i, 1)) = ""
   Next i
   [c2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)

 a = Range("C2:D" & [C65000].End(xlUp).Row)
   For i = LBound(a) To UBound(a)
      b = Range("A2:B" & [A65000].End(xlUp).Row)
      For k = LBound(b) To UBound(b)
         QV = IIf(b(k, 1) = a(i, 1), QV & ", " & b(k, 2), QV)
      Next
      Arr = Split(QV, ", ")
      QV = ""
  Set d = CreateObject("Scripting.Dictionary")
   For x = 1 To UBound(Arr)
     d(Arr(x)) = ""
   Next
   res = d.keys
   For k = 1 To d.Count
      QS = QS & res(k - 1) & ", "
   Next
      a(i, 2) = Mid(QS, 1, Len(QS) - 2)
      QS = ""
   Next
Range("C2:D" & [C65000].End(xlUp).Row) = a
End Sub

Compter une trentaine de seconde pour les 12 000 lignes... (car pour tenir compte que la liste ne serait sans doute pas triée, je n'ai rien optimisé , Chaque item unique parcourt donc les 12000 lignes

(soit au moins 30 000 000 de boucles + les boucles secondaires...)

A+

Le 13/05/2016 à 09:17

Bonjour,

Dans ce cas, je vous propose un extrait de fichier avec des noms factices de propriétaires, correspondant à la structure du tableau, le nombre de lignes en moins :

28exemple-propcde-2.xlsx (8.42 Ko)

En vous remerciant d'avance de vos réponses.

Bien cordialement,

Le 13/05/2016 à 09:23

Bonjour,

Compte tenu de la méthode, le code précédent convient que la colonne A soit numérique ou alphabétique...

Pour la deuxième demande il suffit de Convertir la colonne D (Données > Convertir avec le séparateur virgule

...et ensuite de supprimer l'espace de gauche...

A+

Le 13/05/2016 à 10:06

Une petite retouche avec le séparateur virgule seulement : Comme ça, il y a juste à convertir pour obtenir la colonne D pour parser sur plusieurs cellules...

Sub Galopin()
   Set mondico = CreateObject("Scripting.Dictionary")
   a = Range("A2:A" & [A65000].End(xlUp).Row)
   For i = LBound(a) To UBound(a)
     mondico(a(i, 1)) = ""
   Next i
   [c2].Resize(mondico.Count, 1) = Application.Transpose(mondico.keys)

 a = Range("C2:D" & [C65000].End(xlUp).Row)
   For i = LBound(a) To UBound(a)
      b = Range("A2:B" & [A65000].End(xlUp).Row)
      For k = LBound(b) To UBound(b)
         QV = IIf(b(k, 1) = a(i, 1), QV & "," & b(k, 2), QV)
      Next
      Arr = Split(QV, ",")
      QV = ""
  Set d = CreateObject("Scripting.Dictionary")
   For x = 1 To UBound(Arr)
     d(Arr(x)) = ""
   Next
   res = d.keys
   For k = 1 To d.Count
      QS = QS & res(k - 1) & ","
   Next
      a(i, 2) = Mid(QS, 1, Len(QS) - 1)
      QS = ""
   Next
Range("C2:D" & [C65000].End(xlUp).Row) = a
End Sub

A+

Le 13/05/2016 à 23:19

Bonsoir galopin01, SMPSS, MFerrand, le forum

Si j'ai bien compris, les colonnes A et B contiennent des doublons qu'il faut supprimer.

A tester :

Option Explicit
Sub test()
Dim a, i As Long, n As Long, w()
    With Sheets("Feuil1").Cells(1).CurrentRegion
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To 2)
        n = 1: b(n, 1) = a(1, 1): b(n, 2) = "CDE_1"
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    n = n + 1: ReDim w(1 To 2)
                    w(1) = n
                    Set w(2) = CreateObject("Scripting.Dictionary")
                    w(2).CompareMode = 1
                    w(2)(a(i, 2)) = Empty
                    b(n, 1) = a(i, 1): b(n, 2) = a(i, 2)
                    .Item(a(i, 1)) = w
                Else
                    w = .Item(a(i, 1))
                    If Not w(2).exists(a(i, 2)) Then
                        w(2)(a(i, 2)) = Empty
                        If UBound(b, 2) < 1 + w(2).Count Then
                            ReDim Preserve b(1 To UBound(a, 1), 1 To 1 + w(2).Count)
                        End If
                        b(w(1), 1 + w(2).Count) = a(i, 2)
                    End If
                    .Item(a(i, 1)) = w
                End If
            Next
        End With
    End With
    'Restitution
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(1).Resize(n, UBound(b, 2))
        .CurrentRegion.Clear
        .Value = b
        If UBound(b, 2) > 2 Then
            With .Offset(, 1).Resize(1, 1)
                .AutoFill .Resize(, UBound(b, 2) - 1)
            End With
        End If
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround Weight:=xlThin
        With .Rows(1)
            .Font.Size = 11
            .Interior.ColorIndex = 44
            .HorizontalAlignment = xlCenter
            .BorderAround Weight:=xlThin
        End With
        .Columns.AutoFit
        '.Columns.ColumnWidth = 20
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Le 28/06/2016 à 15:33

Bonjour à tous !

La macro de galopin01 fonctionne parfaitement. J'ai utilisé une variante avec un séparateur point-virgule pour certains contenus contenant des virgules en remplaçant "," par ";" dans la macro.

Au passage, je tiens à m'excuser pour le délai de réponse.

Encore merci !

Rechercher des sujets similaires à "concatener valeurs uniques"