Sub SupprimeDoublons()
'se lance par les touches Ctrl+D
Dim t#, d As Object, derlig&, i&, x$, n&
t = Timer
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
derlig = Range("K" & Rows.Count).End(xlUp).Row
Range("B4:C" & derlig).UnMerge 'défusionne les cellules en colonnes B:C
With Range("X4:X" & derlig) 'colonne auxiliaire
.Value = 1
For i = derlig To 4 Step -1
If IsDate(Cells(i, 10)) And Cells(i, 11) <> "" And Cells(i, 12) <> "" Then
x = Int(Cells(i, 10)) & Cells(i, 11) & Cells(i, 12)
If d.exists(x) Then Cells(i, 24).Resize(6) = "a": n = n + 1 Else d(x) = ""
End If
Next
.EntireRow.Sort .Cells(1), xlAscending, Header:=xlNo 'tri pour accélérer
On Error Resume Next 's'il n'y a pas de SpecialCell
.SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
.Value = ""
End With
[D:D].Replace "du", 0
Intersect([B:C], [D:D].SpecialCells(xlCellTypeConstants, 1).EntireRow).Merge 'refusionne
[D:D].Replace 0, "du"
With ActiveSheet.UsedRange: End With 'actualise les barres de défilement
Application.ScreenUpdating = True
MsgBox n & " zones de 6 lignes supprimées en " & Format(Timer - t, "0.00 \s")
End Sub