VBA Excel suppression des doublons [Fermé]

Signaler
Messages postés
308
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
16 janvier 2013
-
tito23
Messages postés
308
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
16 janvier 2013
-
Bonjour,
Je voudrais chercher toutes les occurrences doublons d'un colonne dans un autre colonne(ici E et F) s' il y a un doublon alors il faudra changer la cellule de la colonne 'E' en "doublon", idéalement supprimer toutes les cellules de la même ligne du doublon jusqu'à la cellule se trouvant sur colonne 'E'.
J'ai testé ce code mais ça marche pas!!
Et merci d'avance de votre aide.
Sub test()


Dim i As Double
Dim j As Double
i = 1
j = 1
With Worksheets("filtre") ' On parcourt la colonne E
Do While (.Range("E" & i) <> "fin")
'on parcourt la colonne F
Do While (.Range("F" & j) <> "fin")
If (.Range("E" & i) = .Range("F" & j)) Then
.Range("E" & i) = "doublon"
Exit Do
End If
j = j + 1
Loop

i = i + 1

Loop
' Ici on teste la cellule actuelle :
End With
End Sub


5 réponses

Messages postés
16081
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
14 février 2020
2 876
Bonjour

idéalement supprimer toutes les cellules de la même ligne du doublon se trouvant sur la colonne 'E' jusqu'à la colonne 'E'.

Oui ????
tito23
Messages postés
308
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
16 janvier 2013
3
c à dire jusqu'à la cellule se trouvant sur la colonne E
Messages postés
308
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
16 janvier 2013
3
up :)
Messages postés
308
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
16 janvier 2013
3
Bonjour,
J'ai trouvé une solution.Mais très lourde vu que j'ai 600000 enregistrement dans mon fichier excel.
S'il y a une amélioration, je suis preneur (effectuer la suppression dans la première boucle)
Voici le code
Sub Doublon()
 
    Dim Plage_E As Range
    Dim Plage_F As Range
    Dim PlageTempo As Range
    Dim Cel_E As Range
    Dim Cel_F As Range
    Dim I As Integer
    
    'défini les plages
    Set Plage_E = Range([E1], [E65536].End(xlUp))
    Set Plage_F = Range([F1], [F65536].End(xlUp))
 
    For Each Cel_E In Plage_E
    
        'recherche la valeur de chaque cellule de la colonne E dans
        'la colonne F
        Set Cel_F = Plage_F.Find(Cel_E, , xlValues)
        
        'si une occurence est trouvé dans la colonne F
        'inscrit "Doublon" dans la cellule concernée de la colonne E
        If Not Cel_F Is Nothing Then
        
                Cel_E = "Doublon"
 
        End If
        
    Next Cel_E
    
    'pour la suppression de cellules, il est préférable
    'de parcourir la plage en partant de la fin
    For I = Plage_E.Count To 1 Step -1
        
        'si la cellule Ex contient le mot "Doublon"
        'les cellules de Ax à Ex sont supprimées
        If Plage_E(I) = "Doublon" Then
        
            Range(Plage_E(I).Offset(0, -4), Plage_E(I)).Delete xlUp
            
        End If
    Next I
    
End Sub
Messages postés
16081
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
14 février 2020
2 876
Ok je regarde en fin d'aprem
pour la suppression; un "clearcontents" ne suffirait il pas ?
Michel
Messages postés
16081
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
14 février 2020
2 876
Tout compte fait en guise d"apéro

Sub supp_doublons() 
Dim Lig_E As Long, Lig_F As Long 
Dim Dico_F As Object, Cptr As Long 
Dim Ref  'a compléter 
Dim T_out, Cptr_t As Long 
Dim start As Single 'pour essai rapidité 

start = Timer 'essai 
'mémorise colonne F 
Lig_F = Cells(Cells.Rows.Count, 6).End(xlUp).Row 
Set Dico_F = CreateObject("scripting.dictionary") 
For Cptr = 2 To Lig_F 
    Ref = Cells(Cptr, 6) 
    If Not Dico_F.exists(Ref) Then 
        Dico_F.Add Ref, Ref 
    End If 
Next 

'mémorise lignes en doublon dans E 
Lig_E = Cells(Cells.Rows.Count, 5).End(xlUp).Row 
ReDim T_out(0) 
For Cptr = 2 To Lig_E 
    ReDim Preserve T_out(Cptr_t) 
    Ref = Cells(Cptr, 5) 
    If Dico_F.exists(Ref) Then 
        T_out(Cptr_t) = Cells(Cptr, 5).Row 
       Cptr_t = Cptr_t + 1 
    End If 
Next 

'supprime les valeurs en doublons colonne A à E 
Application.ScreenUpdating = False 
For Cptr = 0 To UBound(T_out) - 1 
    Range(Cells(T_out(Cptr), 1), Cells(T_out(Cptr), 5)).Clear 
Next 

' supprime les cellules vides dans la colonne E et trie 
Range("E2:E" & Lig_E).Sort Range("E2") 

MsgBox Timer - start & " secondes" 

End Sub


temps pour 1000 lignes 0,12 sec

nota: je ne sais pas si la fonction de tri "sort" fonctionne pour 600000 lignes !!!!

sinon, essaies avec cette instruction
Range("E2:E" & Lig_E).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
au lieu de
Range("E2:E" & Lig_E).Sort Range("E2")

Michel
tito23
Messages postés
308
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
16 janvier 2013
3
Bonjour,
Mon code, je l'ai laissé en exécution depuis hier dans le travail.
Y' a t'il une méthode d'exporter mes données vers Access?
michel_m
Messages postés
16081
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
14 février 2020
2 876
Peut ^tre pourrais tu essayer le mien? j'ai l'impression que tu te fous complètement du temps que j'ai passé à essayer de t'aider...
tito23
Messages postés
308
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
16 janvier 2013
3
Bien sur que je vais essayer ta solution le lundi.
Et merci de ton aide.
michel_m
Messages postés
16081
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
14 février 2020
2 876
Abandon du suivi définitif
tito23
Messages postés
308
Date d'inscription
mardi 10 août 2010
Statut
Membre
Dernière intervention
16 janvier 2013
3
Je travaille pas aujourd'hui en plus j'ai pas windows pour tester ton script.