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
Lone-wolf

Lone-wolf

XLDnaute Barbatruc
Bonjour osiris :)

Ton fichier en retour, avec la macro faite par Pascal RICHARD Paritec. Double-clique sur la feuille Base, ensuite regarde le résultat.

EDIT: bonjour pierrejean :)
 

Pièces jointes

  • osiris.xlsm
    15.6 KB · Affichages: 31
Dernière édition:
Vote positif 0 Vote négatif
pierrejean

pierrejean

XLDnaute Barbatruc
Bonjour à tous
Une autre version
Code: 
Sub test()
tablo = Sheets("Base").Range("A2:B" & Sheets("Base").Range("A" & Rows.Count).End(xlUp).Row)
Set dico = CreateObject("Scripting.dictionary")
For n = LBound(tablo, 1) To UBound(tablo, 1)
   x = tablo(n, 1)
   dico(x) = dico(x) & tablo(n, 2) & "|"
Next
a = dico.keys
b = dico.items
For n = LBound(a) To UBound(a)
  Sheets("résultat").Cells(n + 1, 1) = a(n)
  Sheets("résultat").Cells(n + 1, 2).Resize(, UBound(Split(b(n), "|"))) = Split(b(n), "|")
Next
Sheets("résultat").Select
End Sub
 
Vote positif 0 Vote négatif
Lone-wolf

Lone-wolf

XLDnaute Barbatruc
Re osiris

@osiris150

Tu as mis où la macro, dans un module standard ou le module de la feuille?? Sinon ajoute
Application. EnableEvents = False et True

VB: 
Sub copie()
Dim aa, i&, a&, bb, d As Object, n&, cc, y&

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
  
    With Feuil1
        aa = .Range("A2:B" & .Range("A" & Rows.Count).End(3).Row)
    End With
  
    For i = 1 To UBound(aa)
        If aa(i, 1) <> "" And Not d.exists(aa(i, 1)) Then d.Add aa(i, 1), aa(i, 1)
    Next i
  
    bb = d.keys(): n = 1
    d.RemoveAll
  
    ReDim cc(1 To UBound(bb) + 1, 1 To UBound(aa))
    For i = 0 To UBound(bb)
    cc(i + 1, 1) = bb(i)
        For a = 1 To UBound(aa)
            If aa(a, 1) = bb(i) Then
                If Not d.exists(aa(a, 2)) Then
                n = n + 1
                d.Add aa(a, 2), aa(a, 2)
                cc(i + 1, n) = aa(a, 2)
                End If
            End If
        Next a
        n = 1: d.RemoveAll
    Next i
  
    Feuil2.Range("A1:P" & .Range("A" & Rows.Count).End(3).Row).ClearContents
    Feuil2.Range("A1").Resize(UBound(cc), UBound(cc, 2)) = cc
    Application.EnableEvents = True
End Sub
 
Vote positif 0 Vote négatif
osiris150

osiris150

XLDnaute Occasionnel
Je l'ai mise dans un module de la feuille. Par contre je n'arrive pas à tester la dernière macro j'ai un message d'erreur :
upload_2018-7-3_14-6-1.png
 
Dernière édition:
Vote positif 0 Vote négatif
osiris150

osiris150

XLDnaute Occasionnel
j'ai réussi à enlever le message d'erreur mais toujours problème de mémoire.
J'ai testé en module standard ou de la feuille.
Voici la macro que j'ai modifié :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim aa, i&, a&, bb, d As Object, n&, cc, y&

Application.EnableEvents = False
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
With Feuil1
aa = .Range("A3:D" & .Range("A" & Rows.Count).End(3).Row)
End With
For i = 1 To UBound(aa)
If aa(i, 1) <> "" And Not d.exists(aa(i, 1)) Then d.Add aa(i, 1), aa(i, 1)
Next i
bb = d.keys(): n = 1
d.RemoveAll
ReDim cc(1 To UBound(bb) + 1, 1 To UBound(aa))
For i = 0 To UBound(bb)
cc(i + 1, 1) = bb(i)
For a = 1 To UBound(aa)
If aa(a, 1) = bb(i) Then
If Not d.exists(aa(a, 2)) Then
n = n + 1
d.Add aa(a, 2), aa(a, 2)
cc(i + 1, n) = aa(a, 2)
End If
End If
Next a
n = 1: d.RemoveAll
Next i
Sheets("commande").Range("V5:AC10000").ClearContents
Sheets("commande").Range("v5").Resize(UBound(cc), UBound(cc, 2)) = cc
Application.EnableEvents = True
End Sub

et voilà ce que ça m'affiche :

upload_2018-7-3_14-21-46.png
 
Dernière édition:
Vote positif 0 Vote négatif
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
bonsoir,

http://boisgontierjacques.free.fr/fichiers/Cellules/ListeUniquesCode.xls

Code: 
Sub DicoClassique()
Set f = Sheets("bd")
Tbl = f.[A1].CurrentRegion.Value
NbLig = UBound(Tbl)
Set dcode = CreateObject("scripting.dictionary")
dcode.CompareMode = vbTextCompare   ' ignore la casse
For lig = 2 To NbLig       ' remplissage dictionnaire
      dcode(Tbl(lig, 1)) = ""
Next lig
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare   ' ignore la casse
ligne = 1
For Each code In dcode.keys
   ligne = ligne + 1
   d.RemoveAll
   For lig = 2 To NbLig       ' remplissage dictionnaire
     If Tbl(lig, 1) = code Then d(Tbl(lig, 2)) = ""
   Next lig
   f.Cells(ligne, "e") = code
   f.Cells(ligne, "f").Resize(, d.Count) = d.keys
  Next code
End Sub

jb
 
Dernière édition:
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir @osiris150,

Un autre essai encore (via commandes et formule Excel) :
VB: 
Sub Test()
Dim derlig&
Application.ScreenUpdating = False
With Worksheets("Result")
   .Range("a1").CurrentRegion.Clear
   Worksheets("BD").Range("a:b").Copy .Range("a:b")
   .Range("a:b").Sort Key1:=.Range("a1"), order1:=xlAscending, Header:=True, _
         Key2:=.Range("b1"), order2:=xlAscending
   .Range("a:b").RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
   derlig = .Cells(.Rows.Count, "a").End(xlUp).Row
   .Range("c2:c" & derlig).FormulaR1C1 = "=IF(RC[-2]<>R[1]C[-2],RC[-1],RC[-1] & "";"" & R[1]C)"
   .Range("c2:c" & derlig) = .Range("c2:c" & derlig).Value
   .Range("b:b").Delete
   .Range("a:b").RemoveDuplicates Columns:=Array(1), Header:=xlYes
   Worksheets("BD").Range("a1:b1").Copy .Range("a1:b1")
    .Columns(2).TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, _
        TrailingMinusNumbers:=True
   .Range("b1").CurrentRegion.EntireColumn.AutoFit
End With
End Sub
 

Pièces jointes

  • Osiris- sans doublons- v1.xlsm
    17.7 KB · Affichages: 26
Dernière édition:
Vote positif 0 Vote négatif
osiris150

osiris150

XLDnaute Occasionnel
Bonjour à tous et merci pour toutes ces propositions !
La version de Jocelyn est très bien par formule mais vu le nombre de lignes à traiter cela devient trop lourd avec les index...Sinon ça marche impec.
Le code PierreJean marche très bien. par contre, il y a une chose que je précise c'est que la recherche des codes soit se faire par la colonne A de la feuille résultat car en fait c'est une autre liste qui n'est pas liée à celle de la feuille Base et donc on doit juste recopier les nuances dans la feuille résultat sans toucher aux lignes des codes. Du coup le fichier PierreJean n'est pas tout à fait ce que je recherchais même si on en est proche !
Pour Lone- wolf :
Re

@osiris150 : fait un test avec la macro de pierrejean pour voir si tu as toujours ce message d'erreur. Sans le fichier complet moi je ne peux rien faire. Sinon, essaie en ajoutant On error resume next après screenupdating, et On error GoTo 0 avant enableevents = True.
Cliquez pour agrandir...

J'ai inséré comme tu me l'as dit le On error resume next après screenupdating, et On error GoTo 0 avant enableevents = True mais du coup le fichier se bloque ou alors il tourne de manière très lente et rien ne se passe. Du coup pour mieux se rendre compte j'ai mis en pièce jointe les données que j'ai dans mon fichier original. Les codes sont en colonne A et les nuances en colonne D.

Le code de de Jacques Boisgontier m'a l'air très bien par contre je ne sais pas comment l'adapter sachant que comme précisé au début de ma réponse il faut que la recherche du code soit faite à partir de la colonne A de la feuille résultat et que les nuances de la feuille "Base" soient recopiées sur la feuille résultat à partir de la colonne B.

Pour Chris :
Une solution PowerQuery (intégré à 2016, en add on gratuit sur 2013 à télécharger chez MS)
Cliquez pour agrandir...
Je ne sais absolument pas ce que sais que le PowerQuery

Merci d'avance à tous de vous penchez sur ma requête.
Cordialement
 

Pièces jointes

  • Copie de osiris1.xlsm
    1.2 MB · Affichages: 461
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
118
filiph79
F
A
  • Question
Microsoft 365 valeurs de cellules
Réponses
7
Affichages
227
auloin
A
A
  • Question
XL 2019 Filtre avancé en VBA
Réponses
12
Affichages
304
Amilo
A
D
  • Résolu(e)
Microsoft 365 fonction de recherche multiple
Réponses
3
Affichages
227
dd_76
D
chris6999
  • Question
Microsoft 365 MACRO VBA - Extraire des listes à partir d'une boucle
Réponses
5
Affichages
199
chris6999
chris6999
Z
  • Question
Microsoft 365 Copier valeur cellule suivant le resultat d'une autre
Réponses
13
Affichages
312
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
399
chaelie2015
chaelie2015
B
  • Résolu(e)
Microsoft 365 extraction sans doublon sur une ligne
Réponses
6
Affichages
309
R@chid
R@chid
F
  • Résolu(e)
Microsoft 365 Valeur Label suivant couleur TextBox
Réponses
3
Affichages
138
Francky79
F

Membres actuellement en ligne

12 membres et 140 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 198
Messages
2 086 107
Membres
103 120
dernier inscrit
83400ren