VBA Excel suppression des doublons

Question

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

michel_m · Answer

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 · Answer

up :)

tito23 · Answer

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

michel_m · Answer

Ok je regarde en fin d'aprem 
pour la suppression; un "clearcontents" ne suffirait il pas ? 
 Michel

michel_m · Answer

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

VBA Excel suppression des doublons

5 réponses

Newsletters