XL 2013 Extraction valeurs unique suivant critère

[osiris150]

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

 

[osiris150]

Bonjour à tous,

je m'excuse de remettre ce post au goût du jour mais j'avais juste une petite requête à demander à Mr BOISGONTIER.
J'utilise sa macro ci-dessous et en fait j'aimerais avoir une version qui ne prend pas seulement les valeurs uniques mais toutes les valeurs.
J'ai beau tenter de modifier la macro mais je n'y arrive pas.
En vous remerciant par avance pour votre aide.
Cordialement

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" & 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

 

[BOISGONTIER]

Bonjour,

>j'aimerais avoir une version qui ne prend pas seulement les valeurs uniques mais toutes les valeurs.

Je ne comprends pas la question. Quelles valeurs?

-Sur cette version, il y a les codes déjà présents dans Résultat(colonne c):

http://boisgontierjacques.free.fr/fichiers/Cellules/RegroupeUniquesCode2.xlsm

-Sur cette version, il y a les codes de la BD qui ont une nuance:

http://boisgontierjacques.free.fr/fichiers/Cellules/RegroupeUniquesCode.xlsm

Si on veut la liste de tous les codes, y compris ceux qui n'ont pas de nuance,il faut remplacer :

If Tbl(i, 2) <> "" Then d1(Tbl(i, 1) & "|" & Tbl(i, 2)) = ""

par

d1(Tbl(i, 1) & "|" & Tbl(i, 2)) = ""


jb

 

[osiris150]

Bonjour Mr BOISGONTIER et merci d'avoir pris le temps de me répondre.
En fait je voudrais que votre macro me serve pour 2 cas de figures. Le cas avec les nuances uniques par codes, celui-ci est fonctionnel, et l'autre en fonction de quantités mais pas de nuances et il faut toutes les prendre mêmes celles qui sont à zéro.
Pour être plus clair je vous remets le fichier Excel avec le résultat souhaité, ce sera plus simple à comprendre car je m'explique très mal...Désolé
Cordialement

 

[BOISGONTIER]

cf PJ

  Set f = Sheets("base")
  Set d1 = CreateObject("Scripting.Dictionary")
  Set d2 = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("A2:E" & f.[a65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)
   tmp = "'" & Tbl(i, 1)
   If Tbl(i, 4) <> "" Then d1(tmp) = d1(tmp) & Tbl(i, 5) & "|"
  Next i
  Set f2 = Sheets("résultat2")
  Tbl2 = f2.Range("c2:c" & f.[c65000].End(xlUp).Row).Value  ' préparation qte
  For i = LBound(Tbl2) To UBound(Tbl2)
    tmp = "'" & Tbl2(i, 1)
    If d1.exists(tmp) Then x = d1(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

 

[osiris150]

Excusez-moi mais je ne vois pas de pièce jointe...

 

[osiris150]

C'est parfait !! Merci vraiment ça va beaucoup m'aider.
Je vous souhaite une excellent journée
Cordialement