Sub supDoublons()
Set d = CreateObject("Scripting.Dictionary")
For Each c In Range("a1:A" & [a65000].End(xlUp).Row)
d(c.Value) = d(c.Value) + 1
Next c
For i = [a65000].End(xlUp).Row To 1 Step -1
tmp = Cells(i, 1)
If d(tmp) > 1 Then Cells(i, 1).EntireRow.Delete
Next i
End Sub