Effacer ligne au complet pour les doublons Fermé

Question

Bonjour,

J'ai utilisé la formule suivante pour mettre en évidence mes doulbons. J'aimerais par la suite effacer au complet les lignes dans ma colonne A qui sont des doublons (en rouge). J'ai environ 3000 lignes

Sub Doublons()
Dim Collec As New Collection, Cell As Range, Plage As Range

On Error Resume Next
Set Plage = Application.InputBox("Plage à examiner", Type:=8)
If IsEmpty(Plage) Then Exit Sub

For Each Cell In Plage
If Cell.Value <> "" Then
Collec.Add Cell.Value, CStr(Cell.Value)
If Err <> 0 Then
Err.Clear
Cell.Interior.ColorIndex = 3
Else
Cell.Interior.ColorIndex = 4
End If
End If
Next Cell

Merci pour votre aide

osanowo · Answer

Sub SuppressionDoublons()
    Dim lngLastRow As Long, rngTemp As Long
    
'détermine la dernière ligne utilisée dans la feuille active
lngLastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

'ligne de départ pour la suppression
rngTemp = 1

'commence la boucle de suppression des doublons
Do While rngTemp <= lngLastRow
    
    'supprime la ligne si elle est en rouge, réduit d'autant la dernière ligne de traitement
    Do While Cells(rngTemp, 1).Interior.ColorIndex = 3
        Rows(rngTemp).Delete
        lngLastRow = lngLastRow - 1
    Loop
    
    'passe à la ligne suivante
    rngTemp = rngTemp + 1
Loop

MsgBox "Suppression des doublons terminée !", vbInformation, "Fin"

End Sub

Effacer ligne au complet pour les doublons

1 réponse

Discussions similaires