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