RÉSOLU: Éliminer les doublons au delà d'un nombre établi

[Gen Rose]

Bonjour,

Je suis à la recherche d'une macro pour éliminer les doublons au delà d'un nombre établi, soit 12 et plus dans le cas présent.

Voici la formule que j'ai trouvé et adapté à mon document:

Sub OrdreRespectéDictionary()
  Set MonDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  n = [A65000].End(xlUp).Row
  i = 1
  Do While i <= n
    If Cells(i, "B") <> "" Then
      If Not MonDico.Exists(Cells(i, "B") & Cells(i, "D")) Then
        MonDico.Add Cells(i, "B") & Cells(i, "D"), Cells(i, "B") & Cells(i, "D")
        i = i + 1
       Else
          Rows(i).EntireRow.Delete
       End If
    Else
       i = i + 1
    End If
  Loop
End Sub

J'ai déjà un fil qui ressemble à celui-ci, mais je me permet de revenir avec ce nouvel exemple d'autant plus que j'ai modifiée et simplifiée ma demande. Je n'ai pas le mérite de cette formule car elle est emprunté sur un autre fil.

Pour en revenir au présent code, j'aimerais aussi que la formule génère son résultat sur autre feuille plutôt que d'écraser la présente.

Merci beaucoup pour votre aide

 

[mapomme]

Re : Éliminer les doublons au delà d'un nombre établi

Bonsoir Genevieve,

Un petit fichier serait le bienvenu et aussi quelques éclaircissements sur votre demande,
A) Pour dire qu'une ligne est doublon d'une autre, d'après votre code, faut il que les cellules des colonnes B des deux lignes soient identiques et
que les cellules des colonnes D des deux lignes soient identiques ?

éliminer les doublons au delà d'un nombre établi, soit 12 et plus dans le cas présent

B) on garde les 11 premières lignes rencontrées identiques (au sens du A) ) et au delà on supprime tout autre ligne identique (au sens du A) ) ?

C) Quelles sont les colonnes à recopier sur une autre feuille?
les colonnes de A à D, les colonnes B et D ou un autre ensemble de colonnes ?

 

[mapomme]

Re : Éliminer les doublons au delà d'un nombre établi

Bonsoir Genevieve,

Un exemple de ce qu'on peut faire avec ce que j'en ai compris.
Lignes en doublon => mêmes valeurs en colonne B et aussi en colonne D
Si sur une ligne, les deux cellules en colonne B et en colonne D sont vides, on efface la ligne.
Si sur une ligne, une des deux cellules en colonne B ou en colonne D est vide, on garde toujours la ligne.
Si sur une ligne, les deux cellules sont remplies, on ne recopie pas les lignes en doublon si leur rang de doublon est >=12.
Quand on copie une ligne de Feuil1 vers Feuil2, on copie la ligne de la colonne 1 à la colonne X
Le résultat est sur la feuille 2.
Pour 10.000 lignes => environ 12s sur mon bouzin.

Sub SupprDoublonSupN()

Const Nsuppr = 12
Dim Mondico, ColonB, ColonD
Dim i As Long, MaxLig As Long, S As String, MaxSupp As Long, T1

T1 = Timer
Application.ScreenUpdating = False
Set Mondico = CreateObject("Scripting.Dictionary")

With Sheets("Feuil1")
    MaxLig = .Cells(Rows.Count, "B").End(xlUp).Row
    i = .Cells(Rows.Count, "D").End(xlUp).Row
    If i > MaxLig Then MaxLig = i
    ColonB = Range(.Cells(1, "B"), .Cells(MaxLig, "B")).Value
    ColonD = Range(.Cells(1, "D"), .Cells(MaxLig, "D")).Value
End With

With Sheets("Feuil2")
    .Range("A:X").Clear
    For i = 1 To MaxLig
        'Traitement suivant les valeurs Vides ou non des colonnes B ou D
        If ColonB(i, 1) = "" And ColonD(i, 1) = "" Then
            ' colonB et ColonD sont toutes les deux vides => on efface la ligne
            ' => on ne copie pas la ligne => on ne fait rien
        ElseIf ColonB(i, 1) = "" Then
            ' seule ColonB est vide => on copie la ligne dans tous les cas
            MaxSupp = MaxSupp + 1
            Sheets("Feuil1").Range(Cells(i, "A"), Cells(i, "X")).Copy _
                Destination:=.Range(.Cells(MaxSupp, "A"), .Cells(MaxSupp, "X"))
        ElseIf ColonD(i, 1) = "" Then
            ' seule ColonD est vide => on garde la ligne dans tous les cas
            MaxSupp = MaxSupp + 1
            Sheets("Feuil1").Range(Cells(i, "A"), Cells(i, "X")).Copy _
                Destination:=.Range(.Cells(MaxSupp, "A"), .Cells(MaxSupp, "X"))
        Else
            ' les deux colonnes sont différentes de vide => on copie si doublon < Nsuppr (12)
            S = "/" & ColonB(i, 1) & "//" & ColonD(i, 1) & "/"
            ' Si le couple ( équivalent à S) existe déjà, on lui rajoute +1 dans dico sinon on le crée avec la valeur 1
            If Mondico.Exists(S) Then Mondico(S) = Mondico(S) + 1 Else Mondico.Add S, 1
            ' on vérifie si l'occurence de S est inférieure à Nsuppr (12) ou non.  Si oui => on copie la ligne
            If Mondico(S) < Nsuppr Then
                MaxSupp = MaxSupp + 1
                Sheets("Feuil1").Range(Cells(i, "A"), Cells(i, "X")).Copy _
                    Destination:=.Range(.Cells(MaxSupp, "A"), .Cells(MaxSupp, "X"))
            End If
        End If
    Next i
    .Activate
End With
    
Application.ScreenUpdating = True
MsgBox Format(Timer - T1, "0.00 s")
End Sub

 

[Gen Rose]

Re : Éliminer les doublons au delà d'un nombre établi

Vraiment, je ne suis pas fière de moi! J'avais justement préparé le fichier avec le code en forme de bouton.

Le voici en p.j.

Entre temps, je vais tester la formule que vous venez de m'envoyer et je vous reviens...encore désolée!!!

Pour plus de précisions;

C'est 12 doublons inclusivement et plus qui doivent êtres condensées en une ligne( B et D doivent êtres identiques pour ce faire);
Cette ligne est au final vide en A et C;
Les autres lignes non triées (celles qui ont 11 lignes et moins) doivent aussi être recopiées sur l'autre feuille, sans modifications;
Au final, nous avons une autre feuille où le seule changement est les doublons éliminés pour les 12 et plus;
Le tableau est le même avec ses 4 colonnes.​

Edit: Au départ, je voulais que le triage se fasse par majorité VS minorité mais il semble que ce soit impossible alors, je vais choisir le chiffre 12 et le modifier si besoin est!

 

[Gen Rose]

Re : Éliminer les doublons au delà d'un nombre établi

J'ai vérifé la macro et même si je mets toutes les lignes pareilles, elle ne trie pas les doublons.

Voici ce qui est important: les colonnes A et C ne doivent pas entrer en ligne de compte; indépendamment de ce qu'il y a ou pas en A et C, le seul critère est: si B et D sont identiques, au nombre de 12 lignes ou plus, résumer en une seule en laissant vide A et C.

Je crois que le problème est dans la définition de S...?

 S = "/" & ColonB(i, 1) & "//" & ColonD(i, 1) & "/"

je tente de voir comment je peux ajuster. En atendant, revoici mon document avec votre bouton (je l'ai nommé pomme ).
Mon bouton original se nomme "Résumer" mais malheureusement, il résume sur la même page et je n'ai pas trouvé comment lui ordonner de le faire sur une autre (j'y travaille).

 

[Efgé]

Re : Éliminer les doublons au delà d'un nombre établi

Bonjour genevieve78, mapomme _ Comme j'ai fait quelque chose, je le poste _ Cordialement

 

[mapomme]

Re : Éliminer les doublons au delà d'un nombre établi

Bonsoir Genevieve,

La macro fonctionne telle que je l'ai décrite et que je l'avais compris. Le seul point est qu'elle bloque si la feuille active n'est pas la feuille Feuil1. Ce serait à corriger (voir plus bas)

Tes explications ne m'ont pas éclairé. Que vient faire ce seuil de 12 doublons alors que ta macro 'résumé' ne garde que deux lignes ?
( la ligne 'Michel' est répétée 12 fois et un seul exemplaire est conservé alors que la ligne Jacqueline' n'en comporte que 8 et qu'une seule ligne est aussi conservée)

Le S ne change rien au résultat. L'ajout des 'slash' aurait permis de répérer les vrai doublons lors d'une concaténation car je ne connaissais pas le format des colonnes B et D. C'était juste pour différencier la ligne B=123 et D=456 de la ligne B=12 et D=3456 qui auraient donné le même résultat une fois B et D concaténés (123456) alors que ce n'était pas deux lignes doublonnées.

Tu parles de TRI et de remise à blanc des colonnes A et C => ça ne figurait pas dans le message d'origine.

Du coup, je ne sais plus....


NB: correction citée plus haut. Remplacer la ligne:

                Sheets("Feuil1").Range(Cells(i, "A"), Cells(i, "X")).Copy _
                    Destination:=.Range(.Cells(MaxSupp, "A"), .Cells(MaxSupp, "X"))

par la ligne:

Sheets("Feuil1").Range(Sheets("Feuil1").Cells(i, "A"), Sheets("Feuil1").Cells(i, "X")).Copy _
                    Destination:=.Range(.Cells(MaxSupp, "A"), .Cells(MaxSupp, "X"))

 

[Gen Rose]

Re : Éliminer les doublons au delà d'un nombre établi

OH WoW Efgé!! C'est exactement ça!

Dis-moi, est-ce possible que la feuille 1 demeure inchangée? Avec ta macro, elle se transfère selon le format désiré sur la feuille 2 mais vide complètement la feuille 1 (chaque feuille qui sera nettoyée par ce code aura entre 30 000 et 65 000 lignes). Je vais ensuite exporter ces feuilles "nettoyées" vers un autre classeur donc je veux conserver le classeur original, au cas...

Amicalement,

 

[Gen Rose]

Re : Éliminer les doublons au delà d'un nombre établi

@ mapomme

Merci beaucoup pour ton aide dans ce dossier, c'est sincèrement apprécié!

Tes explications ne m'ont pas éclairé. Que vient faire ce seuil de 12 doublons alors que ta macro 'résumé' ne garde que deux lignes ?

en effet, ma macro "résumé" était problématique; je voulais que les 12 lignes n'en fassent qu'une et que les 8 lignes restent tel quelles...ce qui n'était pas le cas, comme tu as pu le constater! Donc, je cherchait à insérer à cette macro la condition 12 et plus.

Tu parles de TRI et de remise à blanc des colonnes A et C => ça ne figurait pas dans le message d'origine.
Du coup, je ne sais plus....

oui, je sais et je suis désolé pour la confusion; j'aurais du préciser plus tôt que les colonnes A et C n'avaient aucune importance dans le tri et donc, qu'elle soient vides pour la colonne condensée fait alors du sens étant donné que la ville et le code postal ne sont plus pertinents.

Efgé a trouvé une solution presque parfaite (sauf qu'elle efface la feuille 1) contrairement à ton code.

Encore merci pour ton temps mapomme!

 

[Efgé]

Re : Éliminer les doublons au delà d'un nombre établi

Re
Je mets le code sans la suppression du tableau d'origine et avec une modification dans la confition (>11 et non = 12)...

Sub Test()
Dim i&, Dico As Object, TabTmp As Variant, c As Variant
Dim Rng As Range, LstCel As Range
Set Dico = CreateObject("Scripting.Dictionary")
With Sheets("Feuil1")

    For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
        Dico(.Cells(i, 2).Value & .Cells(i, 4).Value) = Dico(.Cells(i, 2).Value & .Cells(i, 4).Value) & ";" & i
    Next i
    
    For Each c In Dico.Keys

        TabTmp = Split(Dico(c), ";")
        Set LstCel = Sheets("Feuil2").Cells(Rows.Count, 2).End(xlUp)(2).Offset(, -1)
        
        Select Case UBound(TabTmp)
            Case Is > 11 ' a 12 on "concatène"
                .Range(.Cells(TabTmp(1), 1), .Cells(TabTmp(1), 4)).Copy LstCel
                Union(LstCel, LstCel.Offset(, 2)).ClearContents
            Case Else
                For i = LBound(TabTmp) + 1 To UBound(TabTmp)
                    If Rng Is Nothing Then
                        Set Rng = .Range(.Cells(TabTmp(i), 1), .Cells(TabTmp(i), 4))
                    Else
                        Set Rng = Union(Rng, .Range(.Cells(TabTmp(i), 1), .Cells(TabTmp(i), 4)))
                    End If
                Next i
                Rng.Copy LstCel
        End Select
        
        Set Rng = Nothing
    Next c
    
    'Ici on supprime les données
    '.Range(Cells(2, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 4)).Clear
End With
End Sub

Cordialement

 

[Gen Rose]

Re : Éliminer les doublons au delà d'un nombre établi

@Efgé

...Par contre, si je veux changer la condition "12 et plus", comment je peux m'y prendre?

Je commence en VBA et je m'attendais à voir 12 quelque part...c'est beau la naïveté...

 

[Gen Rose]

Re : Éliminer les doublons au delà d'un nombre établi

Ah, il y a vraiment un 12... j'aimerais bien deleter mon message précédent!!

Merci Efgé pour ton aide et désolé pour les questions complètements inutiles