Liste sans doublon + tri

Bonjour le forum,

j'utilise cette macro afin d'avoir une liste sans doublon à partir d'un tableau (merci Ergotamine)

Sub DOUBLONS()
Dim DICO As Object, REF As Range
With Worksheets("Feuil1")
    Set DICO = CreateObject("Scripting.Dictionary")
    For Each REF In .[D2:F8]
      If REF <> "" Then DICO(REF.Value) = ""
    Next REF
    .[A13].CurrentRegion.ClearContents
    .[A13].Resize(DICO.Count, 1) = Application.Transpose(DICO.keys)
    .[A13].CurrentRegion.Sort .[A12], xlAscending
End With
End Sub

J'aimerais savoir si il était possible de trier en même temps les données correspondantes à chaque valeur par ligne (voir fichier joint)

* la macro sur la feuille 1

*en feuille 2 : ce que j'obtient

*en feuille 3 : ce que je cherche à obtenir

En espérant que cela soit assez clair.

Cdlt.

16test3-copie.xlsm (26.31 Ko)

Bonjour,

Encore moi en ayant updaté mon code :

Sub DOUBLONS()
Dim DICO As Object, REF As Range, LR%
With Worksheets("Feuil1")
    LR = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set DICO = CreateObject("Scripting.Dictionary")
    For Each REF In .[D2:F7]
        If REF <> "" And WorksheetFunction.CountIf(Range("A13:A" & LR), REF) = 0 Then
            DICO(REF.Value) = ""
        End If
    Next REF
    .Cells(LR, 1).Offset(1).Resize(DICO.Count, 1) = Application.Transpose(DICO.keys)
    .Range("E13:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Sort .[A12], xlAscending
End With
End Sub

Cdlt,

Bonjour,

Je teste l'update dès que possible.

En attendant, merci encore.

Cdlt,

Bonjour,

La macro comme j'ai compris (c'est à dire pour transposer le résultat sur une autre feuille)

Voir en pièce jointe.

10diconico68.xlsm (37.12 Ko)

Nota : il est aisé de transposer pour la feuille 1, mais comme celle d'Ergotamine elle provoque une erreur si on la lance plusieurs fois... en feuille1.

Sur une feuille déportée on peut la relancer à tout moment.

Pour les curieux . Cet exemple semble plus compliqué mais il me semble plus générique :

En effet il se base non seulement sur un Dico mais sur un Dico à Items en Array (donc récupérable n'importe où...)

A+

Bonjour Ergotamine, Galopin01

Ergotamine : j'avais adapter votre première macro à mon fichier car en réalité la liste se reporte sur une autre feuille

ce qui me donne :

Sub DOUBLONS()
Dim Dico As Object, REF As Range
With Worksheets("Feuil1")
    Set Dico = CreateObject("Scripting.Dictionary")
    For Each REF In .[D2:F7]
      If REF <> "" Then Dico(REF.Value) = ""
    Next REF
    Worksheets("Feuil2").[A3].CurrentRegion.ClearContents
    Worksheets("Feuil2").[A3].Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
    Worksheets("Feuil2").[A3].CurrentRegion.Sort Worksheets("Feuil2").[A2], xlAscending
End With
End Sub

J'ai eu la prétention de pouvoir faire la même avec l'update mais c'est une toute autre histoire...

Galopin01 : j'ai testé la votre et le résultat était "presque" concluant.

je dis presque car dans l'absolu, ma liste se trouve uniquement en feuille 2 (votre Tref se réfère à un tableau en feuille 1 qui en réalité n'y est pas)

Du coup (et je conçoit que j'aurait dû directement mettre la bonne version) je vous joint le fichier tel qu'il devrait être (J'ai laissé les 2 macros d'Ergotamine sachant que la 2ème du coup, dans l'état, ne fonctionne pas)

8test3-copie.xlsm (21.89 Ko)

Merci d'avance pour le travail supplémentaire.

Cdlt,

Et donc ce résultat trié on l'affiche ou ?

Bonjour,

En supposant qu'on doit l'afficher en feuille 2 du coup :

Sub DOUBLONS2()
Dim Dico As Object, REF As Range, LR%
LR = Worksheets("Feuil2").Cells(Worksheets("Feuil2").Rows.Count, 1).End(xlUp).Row
With Worksheets("Feuil1")
    Set Dico = CreateObject("Scripting.Dictionary")
    For Each REF In .[D2:F7]
        If REF <> "" And WorksheetFunction.CountIf(Worksheets("Feuil2").Range("A3:A" & LR), REF) = 0 Then
            Dico(REF.Value) = ""
        End If
    Next REF
End With
If Dico.Count = 0 Then MsgBox "Aucune donnée à transferer", vbInformation: Exit Sub
Worksheets("Feuil2").Cells(LR, 1).Offset(1).Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
Worksheets("Feuil2").Range("E3:A" & LR + Dico.Count).Sort Worksheets("Feuil2").[A2], xlAscending
End Sub

Cdlt,

PS : @galopin01 : Je pense qu'il manque "A3" en D6 et "C3" en F6 dans l'exemple qu'on doit re transposer en feuille 2.

En supposant qu'on veut l'affichage en Feuil1 du coup !

6diconico68-v2.xlsm (28.18 Ko)

EDIT : Mébon... Tu peux bien l'afficher n'importe ou !

A+

Re-bonjour,

Galopin01 : je pense que je me suis mal exprimé :

Mon tableau en Feuille1, ma liste sans doublon en Feuille 2 (avec les versions, date de création et dates de modifications correspondantes)

Lorsque je supprime ou ajoute une donnée dans mon tableau, la macro doit mettre à jour ma liste (avec concordance des données) en feuille 2

Ergotamine : la macro fonctionne lors d'un rajout de donnée, mais il faudrait que lorsque je supprime une donnée dans le tableau, cela la supprime dans la liste aussi

Cdlt,

Bonjour,

Je pense qu'il serait bon de donner toutes les conditions dès le début. Une solution non optimisée mais qui donne le résultat escompté :

Sub DOUBLONS()
Dim Dico As Object, REF As Range, LR%
Set F1 = Worksheets("Feuil1")
With Worksheets("Feuil2")
    LR = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set Dico = CreateObject("Scripting.Dictionary")
    For Each REF In F1.[D2:F7]
        If REF <> "" And WorksheetFunction.CountIf(.Range("A3:A" & LR), REF) = 0 Then
            Dico(REF.Value) = ""
        End If
    Next REF
    For Each REF In .Range("A3:A" & LR)
        If WorksheetFunction.CountIf(F1.[D2:F7], REF) = 0 Then .Range("A" & REF.Row & ":E" & REF.Row).ClearContents
    Next REF
    If Dico.Count = 0 Then MsgBox "Aucune donnée à transferer", vbInformation: Exit Sub
    .Cells(LR, 1).Offset(1).Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
    .Range("E3:A" & LR + Dico.Count).Sort .[A2], xlAscending
End With
End Sub

Cdlt,

Je passe la main.

A+

Effectivement, je tâcherais d'être plus explicite lors de mes futures requêtes.

Néanmoins, le test est concluant sur la dernière proposition!

Merci à vous 2 pour votre patience malgré les malentendus (et l'agacement que cela a pu générer) et surtout pour le travail fourni.

Cdlt,

Rechercher des sujets similaires à "liste doublon tri"