Const seuil = 2.5 'cote minimum
Const maxi = 6 'nombre maximum de chevaux à afficher
Private Sub CommandButton1_Click()
CommandButton1.Caption = "Classement avec cotes" & _
IIf(CommandButton1.Caption Like "*>*", "", " >= " & seuil)
Classer CommandButton1.Caption Like "*>*"
End Sub
Sub Classer(affiche As Boolean)
Dim dest As Range, t, cote, d As Object, i&, j%, k
Set dest = [S29] '1ère cellule de destination
t = [T23:W27].Resize(, 4) '.Resize au cas où...
cote = [N17:O31] 'à adapter
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For i = 1 To UBound(t)
For j = 1 To 4
If t(i, j) <> "" Then d(t(i, j)) = d(t(i, j)) + 5 - j
Next j, i
dest.Resize(2, Columns.Count - dest.Column + 1) = "" 'RAZ
If d.Count = 0 Then Exit Sub
With dest.Resize(2, d.Count)
'---restitution---
.Rows(1) = d.keys
.Rows(2) = d.items
'---tri horizontal---
.Sort .Rows(2), 2, .Rows(1), , 1, Orientation:=2
'---cotes avec éliminations éventuelles---
t = .Value: j = 0
For i = 1 To d.Count
k = Application.VLookup(t(1, i), cote, 2, 0)
If IsNumeric(k) Then If (k >= seuil Or affiche) And j < maxi _
Then j = j + 1: t(1, j) = t(1, i): t(2, j) = k
Next i
.Value = "" 'RAZ
If j Then .Resize(, j) = t
'---mises en forme---
.Interior.ColorIndex = xlNone
.Resize(, maxi + 1).Interior.Color = .Cells(0, 0).Interior.Color
If j Then .Rows(1).Resize(, j).Interior.Color = .Cells(1, 0).Interior.Color
If j Then .Rows(2).Resize(, j).Interior.Color = .Cells(2, 0).Interior.Color
.Font.ColorIndex = xlAutomatic
.Font.Bold = True
.HorizontalAlignment = xlCenter
For i = 1 To j
If .Cells(2, i) < seuil Then
.Cells(2, i).Interior.Color = vbRed
.Cells(2, i).Font.ColorIndex = 2
End If
Next i
End With
End Sub
je joins le fichier.
