Sub DblSup()
Dim Sht As Worksheet, Plage As Range, Choix, Col, I As Integer
Const Color = 6740479 ' <- couleur des doublons
For Each Sht In Worksheets ' Pour chaque feuille
Sht.Activate
Sht.AutoFilterMode = False ' On neutralise le filtrage existant
lc = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set Plage = Range("A2", Cells(lr, lc)) ' Définition de la plage à traiter
Choix = InputBox("Feuille " & Sht.Name & vbLf & "Indiquer la plage à traiter", "Doublons???", Plage.Address)
If Choix <> "" Then
' préparation de la feuille
Cells.FormatConditions.Delete
Cells.Interior.Pattern = xlNone
' on formate la colonne 1 en string
Plage.Columns(1).NumberFormat = "@"
For Each Cel In Plage.Columns(1).Cells
Cel.Value = Format(Cel.Value, "0000")
Next
Set Plage = Range(Choix)
Tri_Données Plage
With Plage.FormatConditions.Add(Type:=xlExpression, _
Formula1:="=Dblon(" & Plage.Rows(1).Address(False) & ")")
.Interior.Color = Color
.StopIfTrue = Faux
End With
d1 = Plage.Rows.Count
' on filtre les données pour ne montrer que les doublons
Range("A1", Cells(lr, lc)).AutoFilter Field:=1, Criteria1:=Color, Operator:=xlFilterCellColor
On Error Resume Next
d2 = Plage.SpecialCells(xlCellTypeVisible).Rows.Count
If d2 > 0 Then
ReDim Col(Plage.Columns.Count - 1): For I = 0 To UBound(Col): Col(I) = I + 1: Next
If MsgBox("Les lignes identiques vont être fusionnées", vbCritical + vbOKCancel) = vbOK _
Then Plage.RemoveDuplicates (Col)
Sht.AutoFilterMode = False
lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
d2 = Range("A2", Cells(lr, lc)).Rows.Count
MsgBox d1 - d2 & " lignes ont été supprimées", vbInformation
Else
MsgBox "Aucun doublon trouvé"
Sht.AutoFilterMode = False
End If
End If
Next
End Sub
Sub Tri_Données(Plage As Range)
Dim Cel As Range
' on trie les données dans l'ordre des colonnes comme elles sont
With ActiveSheet.Sort
.SortFields.Clear
For I = 2 To Plage.Columns.Count
.SortFields.Add2 Key:=Plage.Columns(I), SortOn:=xlSortOnValues, Order:=xlAscending ' xlSortTextAsNumbers
Next
.SortFields.Add2 Key:=Plage.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
.SetRange Plage
.Header = xlYes: .MatchCase = False
.Orientation = xlTopToBottom: .SortMethod = xlPinYin
.Apply
End With
End Sub
Function Dblon(Plage As Range) As Boolean
Dim Cel As Range, V As Integer
V = 0: For Each Cel In Plage ' comparaison avec la ligne du dessus
If Cel = Cel.Offset(-1) _
Then V = V + 1 Else Exit For
Next
If V = Plage.Count Then Dblon = True: Exit Function
V = 0: For Each Cel In Plage ' comparaison avec la ligne du dessous
If Cel = Cel.Offset(1) _
Then V = V + 1 Else Exit For
Next
If V = Plage.Count Then Dblon = True: Exit Function
Dblon = False
End Function
