XL 2013 Extraction valeurs unique suivant critère

osiris150

osiris150

XLDnaute Occasionnel
Bonjour le forum,

Je cherche à extraire les valeurs uniques se trouvant en colonne B de la feuille "Base" mais en fonction du code se trouvant en colonne A et afficher les résultat sur la feuille "résultat" comme indiqué sur l'image ci-dessous.
Je vous remercie par avance pour votre aide. Je mets le fichier exemple en PJ
Cordialement
 

Pièces jointes

  • osiris.xlsx
    8.8 KB · Affichages: 43
Trier par date Trier par votes
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Une autre méthode + rapide (0,25 sec pour 35.000 lignes).

Code: 
Sub RegroupeUniquesCode()
  Set f = Sheets("bd")
  Set d = CreateObject("Scripting.Dictionary")
  Set d1 = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("A2:B" & f.[a65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)
   If Tbl(i, 2) <> "" Then d1(Tbl(i, 1) & "|" & Tbl(i, 2)) = ""
  Next i
  For Each c In d1.keys
    a = Split(c, "|")
    d(a(0)) = d(a(0)) & a(1) & "|"
  Next c
  Set f2 = Sheets("résultat")
  n = d.Count
  Dim TblRes: ReDim TblRes(1 To d.Count, 1 To 2)
  i = 0
  For Each c In d.keys
     i = i + 1
     TblRes(i, 1) = c: TblRes(i, 2) = d(c)
  Next c
  f2.[A2].Resize(d.Count, 2) = TblRes
  Application.DisplayAlerts = False
  f2.[B2].Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
  f2.Cells.EntireRow.AutoFit
End Sub

Si les nuances sont en colonnes D, le code devient:

Code: 
Sub RegroupeUniquesCode()
  Set f = Sheets("bd")
  Set d = CreateObject("Scripting.Dictionary")
  Set d1 = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("A2:D" & f.[a65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)    ' élimination doublons nuances
   If Tbl(i, 4) <> "" Then d1(Tbl(i, 1) & "|" & Tbl(i, 4)) = ""
  Next i
  For Each c In d1.keys     ' regroupement par code
    a = Split(c, "|")
    d(a(0)) = d(a(0)) & a(1) & "|"
  Next c
  Set f2 = Sheets("résultat")
  n = d.Count
  Dim TblRes: ReDim TblRes(1 To d.Count, 1 To 2)
  i = 0
  For Each c In d.keys
     i = i + 1
     TblRes(i, 1) = c: TblRes(i, 2) = d(c)
  Next c
  f2.[A2].Resize(d.Count, 2) = TblRes
  Application.DisplayAlerts = False
  f2.[B2].Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
  f2.Cells.EntireRow.AutoFit
End Sub

jb
 

Pièces jointes

  • RegroupeUniquesCode.xlsm
    638.4 KB · Affichages: 26
Dernière édition:
Vote positif 0 Vote négatif
osiris150

osiris150

XLDnaute Occasionnel
Bonjour à tous,

Je tiens à vous remercier chacun d'entre vous pour votre dévouement ! Vraiment c'est un vrai plaisir ce forum :)

Pour chris : tu m'as appris quelque chose car je ne connaissais pas du tout le PowerQuery, j'ai été voir sur le site de microsoft. ça a l'air d'avoir un côté très pratique en effet quand on sait s'en servir ! et pour répondre à ta question dans ton exemple oui le résultat marche parfaitement.

Mais après avoir regardé tous vos exemples je pense que je vais garder celui de Jacques Boisgontier qui est très rapide.
J'ai mis en pièce jointe le fichier tel qu'il se présente réellement dans mon fichier de travail.
Par contre il y aurait besoin d'une petite modification si c'est possible.
On a donc une liste de codes et nuances dans la feuille "Base"
On a une autre liste de données dans la feuille "résultat"
Ce qu'il faut arriver à faire c'est en partant des codes articles de la feuille "résultat" à aller chercher les nuances dans la feuille "base"comme vu précédemment et recopier uniquement ces nuances dans la feuille "résultat" en colonne E par exemple mais sans effacer les codes articles de la feuille "résultat".
Après ça je pense que ce sera parfait.
Merci pour tout.
Cordialement
 

Pièces jointes

  • osiris150.xlsm
    1.5 MB · Affichages: 20
Vote positif 0 Vote négatif
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Bonjour,


Code: 
Sub RegroupeUniquesCode2()   ' 0,32 sec
  Set f = Sheets("base")
  Set d = CreateObject("Scripting.Dictionary")
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("A2:D" & f.[a65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)    ' élimination doublons nuances
   If Tbl(i, 4) <> "" Then d1("'" & Tbl(i, 1) & "|" & Tbl(i, 4)) = ""
  Next i
  For Each c In d1.keys                 ' regroupement par code
    a = Split(c, "|")
    d(a(0)) = d(a(0)) & a(1) & "|"
  Next c
  Set f2 = Sheets("résultat")
  Tbl2 = f2.Range("c2:c" & f.[c65000].End(xlUp).Row).Value
  For i = LBound(Tbl2) To UBound(Tbl2)    ' élimination doublons nuances
    tmp = "'" & Tbl2(i, 1)
    If d.exists(tmp) Then x = d(tmp) Else x = ""
    d2(tmp) = x
  Next i
  f2.[e2].Resize(d2.Count) = Application.Transpose(d2.items)
  Application.DisplayAlerts = False
  f2.[e2].Resize(d2.Count).TextToColumns Other:=True, OtherChar:="|"
  f2.Cells.EntireRow.AutoFit
End Sub

jb
 

Pièces jointes

  • Copie de osiris150.xlsm
    1.6 MB · Affichages: 39
Vote positif 0 Vote négatif
osiris150

osiris150

XLDnaute Occasionnel
Merci PierreJean et Jacques Boisgontier vos 2 solutions répondent parfaitement à ce que je recherchais !
Encore une fois grand merci à vous tous pour votre dévouement. Je vais pouvoir adapter ça à mon projet.
Je vous souhaite une excellente journée
Nicolas
 
Vote positif 0 Vote négatif
pierrejean

pierrejean

XLDnaute Barbatruc
Re

Pour remercier JB de m'avoir fait connaitre le TextToColumns
Voici une version encore plus rapide que les précédentes (qui n’étaient pas consternantes !!!)
Code: 
Sub test()
tablo = Sheets("Base").Range("A2:D" & Sheets("Base").Range("A" & Rows.Count).End(xlUp).Row)
Set dico = CreateObject("Scripting.dictionary")
For n = LBound(tablo, 1) To UBound(tablo, 1)
  x = CStr(tablo(n, 1))
  dico(x) = dico(x) & tablo(n, 4) & "|"
Next
tbres = Sheets("résultat").Range("C2:E" & Sheets("résultat").Range("C" & Rows.Count).End(xlUp).Row)
For n = LBound(tbres, 1) To UBound(tbres, 1)
    tbres(n, 3) = dico(CStr(tbres(n, 1)))
Next
Sheets("résultat").Range("C2:E" & Sheets("résultat").Range("C" & Rows.Count).End(xlUp).Row) = tbres
Application.DisplayAlerts = False
Sheets("résultat").Range("E2:E" & Sheets("résultat").Range("E" & Rows.Count).End(xlUp).Row).TextToColumns Other:=True, OtherChar:="|"
End Sub
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
Bonjour
valeur unique c'est subjectifs
on parle de quoi de valeur unique dans un dico ou de valeur unique présente dans le tableau (colonne"B") c'est pas la même chose

en colonne C et D tu a les codes et nuances sans les doublons
en colonne "E" tu a les valeur vraiment uniques dans la colonne "B"

Code: 
Sub test()
    Dim diconodoublon, list_unique(), elem, i&

    Set diconodoublon = CreateObject("scripting.dictionary")
    Set plage = Range("b2:b" & Cells(Rows.Count, "b").End(xlUp).Row)
    For i = plage.Row To plage.Row + plage.Rows.Count - 1
        If Not diconodoublon.exists(Cells(i, "b").Text) Then
            diconodoublon(Cells(i, "b").Text) = Cells(i, "A").Text
        Else
            diconodoublon(Cells(i, "b").Text) = diconodoublon(Cells(i, "b").Text) & "toto"
        End If
    Next
    For Each elem In diconodoublon
        If Not diconodoublon(elem) Like "*toto*" Then x = x + 1: ReDim Preserve list_unique(1 To x): list_unique(x) = elem
        diconodoublon(elem) = Replace(diconodoublon(elem), "toto", "")
    Next

Cells(2, "c").Resize(diconodoublon.Count, 1) = Application.Transpose(diconodoublon.items)
Cells(2, "d").Resize(diconodoublon.Count, 1) = Application.Transpose(diconodoublon.keys)
Cells(2, "e").Resize(UBound(list_unique), 1) = Application.Transpose(list_unique)
End Sub
 
Vote positif 0 Vote négatif
pierrejean

pierrejean

XLDnaute Barbatruc
Re
La notion de valeur unique n'a rien de subjectif !
Mais effectivement mes macros ne garantissait pas l'unicité des nuances
Ce qui est fait avec celle-ci (à peine plus lente que la précédente)

Code: 
Sub test1()
tablo = Sheets("Base").Range("A2:D" & Sheets("Base").Range("A" & Rows.Count).End(xlUp).Row)
Set dico = CreateObject("Scripting.dictionary")
For n = LBound(tablo, 1) To UBound(tablo, 1)
  x = CStr(tablo(n, 1))
  If InStr(dico(x) & "|", "|" & tablo(n, 4) & "|") = 0 Then dico(x) = dico(x) & "|" & tablo(n, 4)
Next
tbres = Sheets("résultat").Range("C2:E" & Sheets("résultat").Range("C" & Rows.Count).End(xlUp).Row)
For n = LBound(tbres, 1) To UBound(tbres, 1)
    If dico(CStr(tbres(n, 1))) <> "" Then tbres(n, 3) = Right(dico(CStr(tbres(n, 1))), Len(dico(CStr(tbres(n, 1)))) - 1)
Next
Sheets("résultat").Range("C2:E" & Sheets("résultat").Range("C" & Rows.Count).End(xlUp).Row) = tbres
Application.DisplayAlerts = False
Sheets("résultat").Range("E2:E" & Sheets("résultat").Range("E" & Rows.Count).End(xlUp).Row).TextToColumns Other:=True, OtherChar:="|"
End Sub
 
Vote positif 0 Vote négatif
chris

chris

XLDnaute Barbatruc
Bonjour à tous

Pour le fun j'ai testé ce volume avec PQ
On flirte vite avec la saturation mémoire. Je peux sans doute optimiser un peu en retenant plus tôt uniquement les codes de la table Résultat.

Le rafraichissement est plus long que la dernière macro de PierreJean : j'ai environ 5 secondes en VBA et 12 s en PQ
 
Vote positif 0 Vote négatif

Discussions similaires

F
  • Résolu(e)
Microsoft 365 Mise en forme conditionnelle selon la référence d'une cellule
Réponses
3
Affichages
158
filiph79
F
A
  • Question
Microsoft 365 valeurs de cellules
Réponses
7
Affichages
243
auloin
A
A
  • Question
XL 2019 Filtre avancé en VBA
Réponses
12
Affichages
333
Amilo
A
D
  • Résolu(e)
Microsoft 365 fonction de recherche multiple
Réponses
3
Affichages
238
dd_76
D
chris6999
  • Question
Microsoft 365 MACRO VBA - Extraire des listes à partir d'une boucle
Réponses
5
Affichages
221
chris6999
chris6999
Z
  • Question
Microsoft 365 Copier valeur cellule suivant le resultat d'une autre
Réponses
13
Affichages
331
Cousinhub
Cousinhub
P
  • Résolu(e)
Microsoft 365 Nombre de valeurs de type "texte" uniques selon plusieurs critères.
2
Réponses
19
Affichages
1 K
PhilippeLM
P
chaelie2015
  • Résolu(e)
XL 2013 (RESOLU)Nombre de cellule non vide et sans doublon
Réponses
2
Affichages
421
chaelie2015
chaelie2015
B
  • Résolu(e)
Microsoft 365 extraction sans doublon sur une ligne
Réponses
6
Affichages
324
R@chid
R@chid
F
  • Résolu(e)
Microsoft 365 Valeur Label suivant couleur TextBox
Réponses
3
Affichages
164
Francky79
F

Membres actuellement en ligne

7 membres et 53 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 347
Messages
2 087 505
Membres
103 566
dernier inscrit
c@b@l77540