Effacer des doublons, s'ils y en a 4

Sub SupprimeDoublons()
Dim cel As Range, lig As Long
Application.ScreenUpdating = False
[COLOR="Red"][F:I].ClearContents 'par précaution[/COLOR]
For Each cel In Range("A1", [A65536].End(xlUp))
  If cel <> "" And Application.CountIf([A:A], cel) < 4 Then
    lig = lig + 1
    [COLOR="Red"]Cells(lig, "F").Resize(, 4) = cel.Resize(, 4).Value[/COLOR]
  End If
Next
End Sub

Sub SupprimeDoublons()
Dim plage As Range
Application.ScreenUpdating = False
[F:I].ClearContents 'par précaution
[1:1].Insert: [A:A].Insert 'ajout ligne et colonne auxiliaires
Set plage = Range("A1:A" & [B65536].End(xlUp).Row)
plage.FormulaR1C1 = "=AND(RC2<>"""",COUNTIF(C2,RC2)<4)" 'formule en colonne A
ActiveSheet.AutoFilterMode = False
plage.AutoFilter Field:=1, Criteria1:=True 'filtrage sur VRAI
Intersect([B:E], plage.SpecialCells(xlVisible).EntireRow).Copy [G1] 'copie de la zone filtrée
[1:1].Delete: [A:A].Delete 'suppression ligne et colonne auxiliaires
End Sub

Sub a()
[B2].FormulaR1C1 = "=AND(RC1<>"""",COUNTIF(C1,RC1)<4)"
Range([A1], [A65536].End(xlUp)).AdvancedFilter _
    Action:=xlFilterCopy, _
    CriteriaRange:=Range("B1:B2"), _
    CopyToRange:=Range("D1"), _
    Unique:=False
[B:B].Delete
End Sub