Classement complexe par macro
Bonjour à tous,
J'ai un problème de classement assez complexe que je souhaiterais résoudre en automatique (macro)
Actuellement je réalise cette opération en manuel
Au lieu d'écrire un roman sur cette page, je joins le fichier avec toutes les explications et je reste à votre entière disposition pour des renseignements complémentaires.
Merci d'avance de votre généreuse aide
Bonjour,
Ça me semble terriblement complexe car rien ne dit qu'il ne peut pas y avoir 3 ex-aequo voire 4...
Déjà avec 2 c'est pas piqué des vers, avec 3 ou plus, ça me semble quasiment impossible ! (sauf à dire que s'il y a plus de 2 ex-aequo on fera les calculs "à l'ancienne" !
A+
Si, le nombre de points donne l'ordre de rang !
Si les concurrents ont un nombre de points identiques, ce sont des EX AEQUOS pour les places de 4 à 10 !
Et pour les trois premiers ?
Oui, oui...
A+
Je reste persuadé que cette solution est possible en VBA !
Bonjour à tous
Voilà quelques temps, j'ai déposé un problème qu'il me tiens à cœur de résoudre !
Aucune réponse ne m'a été proposée... C'est certainement une mauvaise demande de
ma part ! mal exprimée où qui parait trop complexe.
Si quelqu'un pouvait me rendre ce service, ce serait très gentil ! et je donnerai toutes les explications
nécessaires. Fichier en question ci joint
Merci d'avance
Bonsoir,
Ce qui rend complexe c'est certaines particularités du fichier dont je n'ai pas décelé l'origine mais qu'il convient de corriger !
Il faut veiller à ce que les libellés figurant en A3:A12 soient rigoureusement identiques aux libellés équivalents figurant en K3:K12.
Il faut également que dans la plage L3:U12 les cellules qui ne contiennent pas de valeurs soient alors rigoureusement vides.
Ces conditions étant établies, je te propose une fonction à utiliser dans la colonne H3:H12 pour déterminer le rang :
Function Classement(Pts As Range, Dscr As Range, ACl As String)
Dim d As Object, dpt, pvd, k%, n%, i%, j%, vd#, Tcl()
Application.Volatile False
Set d = CreateObject("Scripting.Dictionary")
With Pts
k = .Columns.Count: n = .Rows.Count
For i = 1 To n
dpt = .Cells(i, 1)
d(dpt) = .Cells(i, k)
Next i
End With
With Dscr
k = .Columns.Count: n = .Rows.Count
For i = 1 To n
dpt = .Cells(i, 1)
If d.exists(dpt) Then
For j = 2 To k
vd = vd + .Cells(i, j) * 10 ^ (6 - j)
Next j
pvd = Array(d(dpt), vd)
d(dpt) = pvd: vd = 0
End If
Next i
End With
ReDim Tcl(d.Count, 3): j = 0
For Each dpt In d.keys
pvd = d(dpt): j = j + 1
Tcl(j, 0) = dpt: Tcl(j, 1) = CInt(pvd(0))
Tcl(j, 2) = Val(Replace(pvd(1), ",", "."))
Next dpt
For i = 1 To UBound(Tcl, 1) - 1
For j = i + 1 To UBound(Tcl, 1)
If Tcl(j, 1) >= Tcl(i, 1) Then
k = IIf(Tcl(j, 1) = Tcl(1, 1), 2, 1)
If Tcl(j, k) > Tcl(i, k) Then
For n = 0 To 2
Tcl(0, n) = Tcl(j, n)
Tcl(j, n) = Tcl(i, n)
Tcl(i, n) = Tcl(0, n)
Next n
End If
End If
Next j
Next i
For i = 1 To 4
Tcl(i, 3) = i
If Tcl(i, 0) = ACl Then Classement = Tcl(i, 3): Exit Function
Next i
n = 4
For i = 5 To UBound(Tcl, 1)
If Tcl(i, 1) = Tcl(i - 1, 1) Then
Tcl(i, 3) = n
Else
Tcl(i, 3) = i: n = i
End If
If Tcl(i, 0) = ACl Then Classement = Tcl(i, 3): Exit Function
Next i
End FunctionLa fonction réclame 3 arguments :
- la plage d'établissements des points : soit ici A3:G12
- la plage qui répertorie les nombres de 1er, 2e... : soit ici K3:U12
- le département dont le classement est recherché : qui figure ici en colonne A en regard de la cellule où l'on place la fonction en colonne H.
Une Sub plutôt qu'une fonction aurait été certainement plus économique, mais elle impliquait quelques aménagements que je n'avais pas trop envie d'entreprendre !
Pour les points en colonne I, on repassera en formule classique :
=LIGNES($H$3:$H$12)+1-H3-(NB.SI($H$3:$H$12;H3)-1)/2+(H3=1)sur l'ensemble de la colonne...
Cordialement.
Merci beaucoup pour cette solution !!
Bien cordialement