Recherche résultats identiques et concatener
Bonjour à tous,
nouveau sur ce forum, je viens demander de l'aide pour résoudre un problème épineux (du moins pour moi !)
mon tableau est sous la forme :
nom article------------------numéro de colis
a -----------------------------------------1
b------------------------------------------1
c------------------------------------------3
d------------------------------------------2
e------------------------------------------2
f ------------------------------------------2
je souhaiterais pouvoir effectuer un tri dans une autre feuille sous cette forme :
numéro de colis---------------------articles présents
1----------------------------------------------a-b
2----------------------------------------------d-e-f
3----------------------------------------------c
la fonction recherchev ne me sort qu'un résultat et j'aimerais si possible que les résultats de recherche soient concaténés dans une même cellule.
Quelqu'un pense que c'est possible ?
Cordialement,
Bonsoir kimeyra
Version VBA :
Option Explicit
Sub test()
Dim a, b(), i As Long, n As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("Feuil1").Range("a1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
n = 1: b(n, 1) = a(1, 2): b(n, 2) = a(1, 1)
For i = 2 To UBound(a, 1)
If Not dico.exists(a(i, 2)) Then
n = n + 1
b(n, 1) = a(i, 2): b(n, 2) = a(i, 1)
dico(a(i, 2)) = n
Else
b(dico(a(i, 2)), 2) = b(dico(a(i, 2)), 2) & "-" & a(i, 1)
End If
Next
Application.ScreenUpdating = False
With Sheets("Feuil2")
.Cells.Clear
.Range("a1").Resize(n, UBound(b, 2)).Value = b
.Activate
End With
Application.ScreenUpdating = True
End Subklin89
Ouah ! ça dépote, merci beaucoup Klin89 !!!
ça fonctionne super !
j'essaie de comprendre ton code mais j'avoue que je m'y perds un peu (je suis un grand débutant sur ce terrain)
est-ce que j'abuserais de ton soutien en te demandant de me faire une seconde version du code avec récupération d'une colonne supplémentaire ?
je m'explique :
nom article------------------ensemble----------------numéro de colis
a -----------------------------------------X2---------------------------1
b------------------------------------------Y4---------------------------1
c------------------------------------------X2---------------------------3
d------------------------------------------X8---------------------------2
e------------------------------------------X2---------------------------2
f ------------------------------------------X8---------------------------2
je souhaiterais pouvoir effectuer un tri dans une autre feuille sous cette forme :
numéro de colis---------------------ensemble--------------------articles présents
1----------------------------------------------X2/Y4-------------------------------a-b
2----------------------------------------------X8/X2------------------------------d-e-f
3----------------------------------------------X2------------------------------------c
En faît, ça me permettrait de comparer pour essayer de comprendre un peu comment ça se passe
Quoiqu'il en soit, je te remercie encore !
Merci Jean Eric,
effectivement, ça fonctionne aussi en revanche, j'ai l'impression que le temps de calcul est plus long avec cette solution (à moins que ça ne vienne de mon pc)
Pour le coup, je suis déjà pas un expert vba mais encore moins Power Query ! je découvre à l'instant son existence
Je vais essayer de fouiller un peu pour en savoir plus sur le sujet...
Re kimeyra,
Ça se complique
Vois ceci :
Option Explicit
Sub test()
Dim a, b(), w, i As Long, e, n As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("feuil1").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not dico.exists(a(i, 3)) Then
ReDim w(1 To 2)
Set w(1) = CreateObject("Scripting.Dictionary")
w(1).CompareMode = 1
Set w(2) = CreateObject("Scripting.Dictionary")
w(2).CompareMode = 1
dico(a(i, 3)) = w
End If
w = dico(a(i, 3))
If Not w(1).exists(a(i, 2)) Then
w(1)(a(i, 2)) = Empty
End If
If Not w(2).exists(a(i, 1)) Then
w(2)(a(i, 1)) = Empty
End If
dico(a(i, 3)) = w
Next
ReDim b(1 To dico.Count + 1, 1 To 3)
n = 1: b(n, 1) = a(1, 3): b(n, 2) = a(1, 2): b(n, 3) = a(1, 1)
For Each e In dico.keys
w = dico(e)
n = n + 1
b(n, 1) = e
b(n, 2) = Join(w(1).keys, "/")
b(n, 3) = Join(w(2).keys, "-")
Next
Application.ScreenUpdating = False
With Sheets("Feuil2")
.Cells.Clear
.Range("a1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
.Activate
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Bonjour,
Bonjour Klin89
Je persévère avec une nouvelle proposition Power Query, plus simple à mettre en place.
Cdlt.
Bonjour Klin89,
bonjour Jean-Eric,
effectivement cela se complique sérieusement !
j'ai testé vos deux solutions et dans chacune d'elle il y a visiblement un bug.
Pour toi Klin89, à partir de la 6ème entrée de numéro de colis, le tri me retourne une date ! comment c'est possible que cela fonctionne sur les 5 premières références et pas après ? j'ai essayé de comprendre ton code mais j'ai vite réalisé que c'était bien au dessus de mes connaissances... (voici mon fichier excel avec mes données si tu veux regarder :
)
Pour toi Jean-Eric, c'est un peu le même type de problème que je rencontre. Tout fonctionne sur les premières entrées, mais quand je copie-colle mes données et que je lance ton script, cela créé de multiples colonnes et certains noms d'ensemble disparaissent.
Voici également ton fichier avec mes données si tu veux jeter un coup d'oeil :
En tout cas, merci à vous deux, c'est vraiment super sympa de m'aider comme vous le faites
Re kimeyra,
Salut Jean-Eric,
Dans ton fichier, je ne sais plus quelles sont les colonnes à traiter exactement
Option Explicit
Sub test()
Dim a, b(), w, i As Long, e, n As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("feuil1").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not IsEmpty(a(i, 2)) Then
If Not dico.exists(a(i, 2)) Then
ReDim w(1 To 2)
Set w(1) = CreateObject("Scripting.Dictionary")
w(1).CompareMode = 1
Set w(2) = CreateObject("Scripting.Dictionary")
w(2).CompareMode = 1
dico(a(i, 2)) = w
End If
w = dico(a(i, 2))
If Not w(1).exists(a(i, 3)) Then
w(1)(a(i, 3)) = Empty
End If
If Not w(2).exists(a(i, 1)) Then
w(2)(a(i, 1)) = Empty
End If
dico(a(i, 2)) = w
End If
Next
ReDim b(1 To dico.Count + 1, 1 To 3)
n = 1: b(n, 1) = a(1, 2): b(n, 2) = a(1, 3): b(n, 3) = a(1, 1)
For Each e In dico.keys
w = dico(e)
n = n + 1
b(n, 1) = e
b(n, 2) = Join(w(1).keys, "/")
b(n, 3) = Join(w(2).keys, "-")
Next
Application.ScreenUpdating = False
With Sheets("Feuil2")
.Cells.Clear
.Range("a1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
.Activate
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Bon bah là, que dire... c'est juste PARFAIT !!!
zero bug, d'une rapidité redoutable bref, que du bonheur !
tu es juste un passionné ou c'est ton métier ?
Re
Les données affichées dans ton fichier ne représentent pas du tout l'exemple illustré plus haut,
pour un même N° de colis ; pas d'éléments différents en colonne C, pas de pièces en doublon en colonne A
Ceci suffit amplement :
Option Explicit
Sub test()
Dim a, b(), i As Long, n As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
a = Sheets("Feuil1").Range("a1").CurrentRegion.Value
ReDim b(1 To UBound(a, 1), 1 To 3)
n = 1: b(n, 1) = a(1, 2): b(n, 2) = a(1, 3): b(n, 3) = a(1, 1)
For i = 2 To UBound(a, 1)
If Not IsEmpty(a(i, 2)) Then
If Not dico.exists(a(i, 2)) Then
n = n + 1
b(n, 1) = a(i, 2): b(n, 2) = a(i, 3): b(n, 3) = a(i, 1)
dico(a(i, 2)) = n
Else
b(dico(a(i, 2)), 3) = b(dico(a(i, 2)), 3) & "|" & a(i, 1)
End If
End If
Next
Application.ScreenUpdating = False
With Sheets("Feuil2")
.Cells.Clear
.Range("a1").Resize(n, UBound(b, 2)).Value = b
.Activate
End With
Application.ScreenUpdating = True
End Subklin89