Bonjour Flam, Phibou le fil,
j'ai archivé une macro que Marco57 avait proposé pour un problème similaire. Elle est en plus commentée, encore merci à lui.
Il te suffit de l'adapter à ta feuille.
=========================
Private Sub cmbAjoutPoints_Click()
Dim DerLigne As Long
Dim Cel As Range
Dim Place As Long
Dim Suite1 As String
Dim Suite2 As String
'Détermination du N°de la dernière ligne
DerLigne = Range('i1').End(xlDown).Row
'Effectue une boucle sur les cellules de la colonne L, ligne2 à dernière ligne
For Each Cel In Range('L2:L' & DerLigne)
If Cel.Value <> '' Then 'si il y a une valeur
'ajoute cette valeur dans la colonne J
Cel.Offset(0, -2).Value = Cel.Offset(0, -2).Value + Cel.Value
'puis efface la valeur de la colonne L
Cel.Value = ''
End If
Next Cel
'Effectue le classement des noms et des points
Columns('I:J').Sort Key1:=Range('J2'), Order1:=xlDescending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Détermine le classement en fonction des points
For Each Cel In Range('H2:H' & DerLigne)
If Cel.Offset(0, 2).Value < Cel.Offset(-1, 2).Value Then
Place = Cel.Row - 1
Else: Place = Place
End If
If Place = 1 Then
Suite1 = ' er'
Else: Suite1 = ' ème'
End If
Cel.Value = CStr(Place) & Suite1
Next Cel
'Ajoute la mention 'ex aequo' si c'est le cas
For Each Cel In Range('H2:H' & DerLigne)
If Cel.Offset(0, 2).Value = Cel.Offset(-1, 2).Value Or _
Cel.Offset(0, 2).Value = Cel.Offset(1, 2).Value Then
Cel.Value = Cel.Text & ' exaequo'
End If
Next Cel
End Sub
===========================
Bon weekend
Didier
