Corriger doublons automatiquement

Sub Doublon()
    Range("A1:D10").Select
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SortFields.Clear
        .SortFields.Add Range("A2:A10"), xlSortOnValues, Ascending, xlSortNormal
        .SortFields.Add Range("B2:B10"), xlSortOnValues, xlAscending, xlSortNormal
        .SortFields.Add Range("C2:C10"), xlSortOnValues, xlAscending, xlSortNormal
        .SortFields.Add Range("D2:D10"), xlSortOnValues, xlAscending, xlSortNormal
        .SetRange Range("A1:D10")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("$A$1:$D$10").RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

Sub es()
 Dim m As Object, i As Long, z As Variant, x As Byte, y As Byte
      Application.ScreenUpdating = 0
    Range("$A$2:$D$" & Cells(Rows.Count, 1).End(3).Row).RemoveDuplicates Columns:=Array(1, 2, 3, 4)
    [a2:d1000].Sort Key1:=[a2], Order1:=xlAscending, Header:=xlGuess
    Set m = CreateObject("Scripting.Dictionary")
    For i = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
    z = Cells(i, 1) & Cells(i, 2)
    If Not m.Exists(z) Then
     m.Add z, z
     Else
     x = Application.WorksheetFunction.CountA(Range(Cells(i, 1), Cells(i, 4)))
     y = Application.WorksheetFunction.CountA(Range(Cells(i + 1, 1), Cells(i + 1, 4)))
    If y < x Then Rows(i + 1).Delete Else Rows(i).Delete
    End If
   Next i
End Sub