Sub Classement()
Dim DerLig As Long, i As Long, j As Long
Dim x As Range
Application.ScreenUpdating = False
DerLig = Range("C" & Rows.Count).End(xlUp).Row
'Tableau de gauche
For i = 2 To DerLig Step 5
For j = 0 To 4
Cells(i + j, "E") = Application.WorksheetFunction.Rank(Cells(i + j, "B"), Range(Cells(i, "B"), Cells(i + 4, "B")))
If Application.WorksheetFunction.CountIf(Range(Cells(i, "B"), Cells(i + j, "B")), Cells(i + j, "B")) > 1 Then Cells(i + j, "E") = Cells(i + j, "E") + 1
Next j
Next i
'Tableau de droite
For i = 2 To DerLig Step 5
With Range(Cells(i, "E"), Cells(i + 4, "E"))
For j = 1 To 5
Set x = .Find(j)
Range(Cells(i + j - 1, "J"), Cells(i + j - 1, "L")).Value = Range(Cells(x.Row, "B"), Cells(x.Row, "D")).Value
Next j
End With
Next i
Set x = Nothing
End Sub