Sub toto()
Dim i&, j&, k&, r, l(), Plg As Range
ReDim l(1, 0)
With Feuil1
With .[A11].Resize(BasDroite(.[F11], 34, "F").Rows.Count, .Columns("P").Column).Cells
'J'utilise la fonction BasDroite pour la sélection précise d'une plage de données.
'Elle n'a rien à voir avec le problème. (Son code est dans le module Service.)
'Relevé des numéros de lignes à copier :
For i = 2 To .Rows.Count
If IsDate(.Cells(i, 6)) Then k = k + 1: ReDim Preserve l(1, k): l(0, k) = .Cells(i, 6).Value: l(1, k) = i
Next
'Classement par date d'ancienneté décroissante :
For i = 1 To k - 1: r = l(0, i): For j = i + 1 To k
If l(0, j) < r Then l(0, i) = l(0, j): l(0, j) = r: r = l(1, i): l(1, i) = l(1, j): l(1, j) = r: r = l(0, i)
Next j, i
'Report des lignes dans la feuille Feuil2 :
Set Plg = Feuil2.[A1]
With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
Plg.CurrentRegion.Clear
.Rows(1).Copy Destination:=Plg
For i = 1 To k
.Rows(l(1, i)).Copy Destination:=Plg.Offset(i)
Next
Plg.Columns("A").Resize(, .Columns.Count).EntireColumn.AutoFit
'Facultatif :
Plg.Parent.Activate
With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
End With
End With
End Sub