Concaténer des valeurs uniques selon des valeurs uniques
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 :
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,
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,
Bonjour,
Mauvaise idée de mettre un nombre pour représenter un nom (texte)...
Cordialement.
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,
Tu n'as apparemment pas conscience de l'attention à accorder à la notion de type de données...
Bonne journée.
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+
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 :
En vous remerciant d'avance de vos réponses.
Bien cordialement,
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+
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+
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
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 !