Sub doublon()
Dim derlign As Long, i As Long, j As Long
Application.ScreenUpdating = False
derlign = [a65536].End(xlUp).Row
i = 2
Do While i <= derlign
j = 0
Do While Left(Cells(i, 1), 8) = Left(Cells(i + j, 1), 8)
j = j + 1
Loop
If j <= 2 Then Rows(i + j - 1 & ":" & i).Delete shift:=xlShiftUp: derlign = [a65536].End(xlUp).Row Else i = i + j
Loop
End Sub