Effacer ligne au complet pour les doublons
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
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
Configuration: Windows Vista Internet Explorer 7.0
1 réponse
-
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
