XL 2010 Rechercher 3 valeurs les plus élevées

Sub Les_3_premiers()
Dim dest As Range, P As Range, ncol%, a(), i&, j&
Set dest = [E2] '1ère cellule, à adapter si nécessaire
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
dest.CurrentRegion.Clear 'RAZ
[A2].CurrentRegion.Copy dest
Set P = dest.CurrentRegion
ncol = P.Columns.Count
ReDim a(1 To P.Rows.Count, 1 To 1)
For i = 1 To UBound(a)
    If P(i, 1) <> "" Then
        With P(i, 1).MergeArea
            .Offset(, 1).Resize(.Count, ncol - 1).Sort .Columns(3), xlDescending, Header:=xlNo 'tri sur la 3ème colonne
            For j = i To i + IIf(.Count < 3, .Count - 1, 2)
                a(j, 1) = 1
            Next j
        End With
    End If
Next i
With P.Columns(ncol + 1)
    .Value = a
    On Error Resume Next 'si aucune SpecialCell
    Intersect(P, .SpecialCells(xlCellTypeBlanks).EntireRow).Delete xlUp
    .ClearContents
End With
End Sub

Sub Les_3_premiers()
Dim dest As Range, P As Range, ncol%, a(), i&, j&
Set dest = [E2] '1ère cellule, à adapter si nécessaire
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData 'si la feuille est filtrée
dest.CurrentRegion.Clear 'RAZ
[A2].CurrentRegion.Copy dest
Set P = dest.CurrentRegion
ncol = P.Columns.Count
ReDim a(1 To P.Rows.Count, 1 To 1)
For i = 1 To UBound(a)
    If P(i, 1) <> "" Then
        With P(i, 1).MergeArea
            .Offset(, 1).Resize(.Count, ncol - 1).Sort .Columns(3), xlDescending, Header:=xlNo 'tri sur la 3ème colonne
            For j = i To i + IIf(.Count < 3, .Count - 1, 2)
                a(j, 1) = 1
            Next j
        End With
    End If
Next i
With P.Columns(ncol + 1)
    .Value = a
    P.Columns(1).UnMerge 'défusionne les cellules
    P.Resize(, ncol + 1).Sort .Cells 'tri sur la colonne auxiliaire
    On Error Resume Next 'si aucune SpecialCell
    Intersect(P, .SpecialCells(xlCellTypeBlanks).EntireRow).Delete xlUp
    .ClearContents
End With
'---bordures---
P.Borders.LineStyle = xlNone
P.SpecialCells(xlCellTypeConstants).Borders.Weight = xlThin
End Sub