Sub MefC()
Dim i&, x As Range
With Application
.ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135
With Feuil2.Columns("B")
Set x = .Cells(1, 1).Offset(Rows.Count - .Cells(1, 1).Row, 0)
ReDim a&(1 To x.End(-4162).Row, 1 To 1)
For i = 1 To UBound(a, 1): a(i, 1) = i: Next
.Insert Shift:=-4161
.Resize(x.End(-4162).Row, 1).Offset(0, -1).Value = a
.Resize(, 3).Offset(0, -1).Sort Key1:=.Offset(0, 1), Order1:=1, Header:=2, OrderCustom:=1, MatchCase:=0, Orientation:=1
.Range(x.Offset(0, 1).End(-4162), x.End(-4162)).Offset(1, 0).EntireRow.Delete
.Resize(, 3).Offset(0, -1).Sort Key1:=.Offset(0, -1), Order1:=1, Header:=2, OrderCustom:=1, MatchCase:=0, Orientation:=1
.Offset(0, -1).Delete Shift:=-4159
End With
.Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1
End With
End Sub