classement

Re : classement

bonjour JonPol
bienvenue sur le forum
question la feuille résultat faut-il la joindre à l'autre fichier et explique ce que représente les colonnes I à Q par rapport à course,saut,lancer,relais
pour faciliter les explications mets nous un exemple de ce que tu veux obtenir
à bientôt

Bonjour

j'ai mis les feuilles dans 2 fichiers distincts pour éviter de dépasser les 48ko mais évidemment tout peut etre dans le meme fichier.

Dans la feuille résultats: les colonnes importantes , sont B (dossard), H (academie), I (n° epreuve, ) et N (les points).
Il faut peut etre ajouter une colonne (macro ou index/equiv ou recherchev?) qui détermine selon le N° epreuve (1à 20) le type d'epreuve (course, saut, lancer, relais). il y a une correspondance entre N° et type dans la feuille parametre.


LA feuille "parametre" détaille la façon de classer:
34perfs indiv= 15course+12saut+8lancer (+1relais)
2perfs maxi par athlètes dans les 34 perfs (doublons oui, triplé non)

Bonne journée
Jonpol

Re : classement

bonsoir jonpol
le fichier esr sur:
http://cjoint.com/?cuwz3EoWUP

la 1ère fois tu cliques sur 'change colonne I',içi déjà fait
ensuite clic 'toutes perfs',tu peux recommencer si tu veux
pour le moment le résultat est en colonne U de la feuille résultats
pour voir le code ,clic droit sur onglet résultats et visualiser le code
à bientôt pour la suite

Re : classement

Bonsoir

Oui dans la colonne U il ya un tri correspondant à ce que je souhaiterais.
J'ai tenté de mettre des perfs de relais:
1 1500 a Versailles 8 1 1 4420 1 25 4*100 <2m
1 1501 b Toulouse 8 1 2 4520 2 24 4*100 <2m
1 1502 c lille 8 1 3 4620 3 23 4*100
1 1503 d Rennes 8 1 4 4720 4 22 4*100 <2m

mais ça n'a pas fonctionné quand j'ai cliclé sur le bouton.
2/Comment faire pour récuperer ensuite les données de la colonne U vers la feuille "toutes perfs"
3/puis les classer dans la feuille "perf classées"
4/ et enfin tirer le classement général

Je sais que c'est beaucoup de questions
merci
Jonpol

Re : classement

bonjour

tu remplaces par ce code

Private Sub PerfClasser()
Dim L As Long, La As Long, Le As Long, Li As Long, Ws As Worksheet, Item
Dim MonDico As Object, Cel As Range, D As Long, F As Long, D1 As Long, F1 As Long
Dim Academie, Ep, Ligne, NbE As Byte

Application.ScreenUpdating = False

Range("U1:X" & Range("U65536").End(xlUp).Row).ClearContents

L = Range("A65536").End(xlUp).Row

Range("A1:Q" & L).Sort Key1:=Range("I2"), Order1:=xlAscending, _
Key2:=Range("H2"), Order2:=xlAscending, Header:=xlGuess

Set MonDico = CreateObject("Scripting.Dictionary")

For Each Cel In Range("I2:I" & L)

If Not MonDico.Exists(Cel.Value) Then MonDico.Add Cel.Value, Cel.Value

Next Cel
ReDim Ep(1 To MonDico.Count, 1 To 3)

For Each Item In MonDico.items
Le = Le + 1: Ep(Le, 1) = Item
Next Item


For Le = LBound(Ep, 1) To UBound(Ep, 1)
Set Cel = Columns("I").Find(Ep(Le, 1))
If Not Cel Is Nothing Then Ep(Le, 2) = Cel.Row '1ère ligne
Ep(Le, 3) = Application.CountIf(Range("I2:I" & L), "=" & Ep(Le, 1)) ' + Ep(Le, 3) - 1
Ep(Le, 3) = (Ep(Le, 3) + Ep(Le, 2)) - 1

Next Le

For Le = LBound(Ep, 1) To UBound(Ep, 1)

Select Case Ep(Le, 1)
Case "course"
NbE = 15
Case "lancer"
NbE = 8
Case "relais"
NbE = 1
Case "saut"
NbE = 12
End Select

Set MonDico = CreateObject("Scripting.Dictionary")

For Each Cel In Range("H" & Ep(Le, 2) & ":H" & Ep(Le, 3))
If Cel.Offset(0, 1) = Ep(Le, 1) Then
If Not MonDico.Exists(Cel.Value) Then MonDico.Add Cel.Value, Cel.Value
End If
Next Cel

Academie = MonDico.items

For La = LBound(Academie, 1) To UBound(Academie, 1)

F = Application.CountIf(Range("H" & Ep(Le, 2) & ":H" & Ep(Le, 3)), "=" & Academie(La))
Set Cel = Range("H" & Ep(Le, 2) & ":H" & Ep(Le, 3)).Find(Academie(La))
If Not Cel Is Nothing Then D = Cel.Row

Lr = Range("T65536").End(xlUp).Row '1ère ligne coller

Range("B" & D & ":N" & D + F - 1).Copy Destination:=Range("U" & Lr)

Li = Range("U65536").End(xlUp).Row 'dernière ligne après coller

If Li > Lr Then Range("U" & Lr & ":AG" & Li).Sort Key1:=Range("AG" & D), Order1:=xlDescending 'X

If Li - Lr > NbE Then
Li = Lr + NbE
Range("U" & Li & ":AG" & Range("U65536").End(xlUp).Row).ClearContents
End If

Range("T" & Range("U65536").End(xlUp).Row + 1) = La
Next La

Next Le

Columns("V:Z").Delete Shift:=xlToLeft
Columns("X:AA").Delete Shift:=xlToLeft
Columns("T").ClearContents
Range("U1:X" & Range("U65536").End(xlUp).Row).Sort Key1:=Range("V1"), Order1:=xlAscending ', _
'Key2:=Range("V1"), Order1:=xlAscending

Application.ScreenUpdating = True

End Sub

il y a des incohérences dans résultats(ex:relais en colonne i,marteau en colonne o
quand cette partie sera au point,étape suivante

à bientôt

Re : classement

Bonjour

1/ Tu as raison, il ya 3 perfs incoherentes, que j'ai modifiées
Versailles relais 1 3 5950 1 8 4*100m
Nancy.Metz relais 1 4 5248 2 12 4*100m
Toulouse relais 1 1 6137 2 3 4*100m

Le classement se fait nickel maintenant.

2/ serait il possible de garder la colonne I avec le n° d'epreuve et de mettre le type en colonen R?
CAr en fait j'ai besoin à un moment donnée, si je fais un classement intermédiaire de la coupe, je ne peux plus continuer avec mes n° d'épreuves

Jonpol

Re : classement

bonjour
nouvau code

le résultat est ds la feuille toutes perfs
attention,il y avait un espace ds la colonne H,académie

Option Compare Text

Private Sub EpNumToText(Optional Test As Boolean)
Dim Cel As Range, LetCol As String, Ws As Worksheet, Col As Byte

LetCol = IIf(Test, "C", "I")
Col = IIf(Test, 0, 9)
Set Ws = IIf(Test, Worksheets("toutes perfs"), ActiveSheet)

Application.ScreenUpdating = False
'change numeric colonne I en texte,colonne R
For Each Cel In Ws.Range(LetCol & "1:" & LetCol & Ws.Range(LetCol & "65536").End(xlUp).Row)

Select Case Cel
Case 17, 18, 19, 20
Cel.Offset(0, Col) = "lancer"

Case 13, 14, 15, 16
Cel.Offset(0, Col) = "saut"

Case 7, 8
Cel.Offset(0, Col) = "relais"

Case Is <= 6
Cel.Offset(0, Col) = "course"

Case 9, 10, 11, 12
Cel.Offset(0, Col) = "course"

End Select

Next Cel

Application.ScreenUpdating = True

End Sub

Private Sub PerfClasser()
Dim L As Long, La As Long, Le As Long, Li As Long, Ws As Worksheet, Item
Dim MonDico As Object, Cel As Range, D As Long, F As Long, D1 As Long, F1 As Long
Dim Academie, Ep, Ligne, NbE As Byte

Application.ScreenUpdating = False
Set Ws = Worksheets("toutes perfs")
Test = False

Ws.Range("A1").CurrentRegion.ClearContents 'Range("A1:N" & Ws.Range("A65536").End(xlUp).Row)
'feuille résultats
L = Range("A65536").End(xlUp).Row

Range("A1:R" & L).Sort Key1:=Range("R2"), Order1:=xlAscending, _
Key2:=Range("H2"), Order2:=xlAscending, Header:=xlGuess

Set MonDico = CreateObject("Scripting.Dictionary")

For Each Cel In Range("R2:R" & L) 'epreuve

If Not MonDico.Exists(Cel.Value) Then MonDico.Add Cel.Value, Cel.Value

Next Cel


ReDim Ep(1 To MonDico.Count, 1 To 3)

For Each Item In MonDico.items
Le = Le + 1: Ep(Le, 1) = Item
Next Item


For Le = LBound(Ep, 1) To UBound(Ep, 1)
Set Cel = Columns("R").Find(Ep(Le, 1))
If Not Cel Is Nothing Then
If Le = 1 Then Ep(Le, 2) = 1 Else Ep(Le, 2) = Cel.Row '1ère ligne
End If
Ep(Le, 3) = Application.CountIf(Range("R2:R" & L), "=" & Ep(Le, 1)) ' + Ep(Le, 3) - 1
Ep(Le, 3) = (Ep(Le, 3) + Ep(Le, 2)) - 1

Next Le

For Le = LBound(Ep, 1) To UBound(Ep, 1)
'nbre maxi ep
Select Case Ep(Le, 1)
Case "course"
NbE = 15
Case "lancer"
NbE = 8
Case "relais"
NbE = 1
Case "saut"
NbE = 12
End Select

Set MonDico = CreateObject("Scripting.Dictionary")

For Each Cel In Range("H" & Ep(Le, 2) & ":H" & Ep(Le, 3))
If Cel.Offset(0, 10) = Ep(Le, 1) Then
If Not MonDico.Exists(Cel.Value) Then MonDico.Add Cel.Value, Cel.Value
End If
Next Cel

Academie = MonDico.items

For La = LBound(Academie, 1) To UBound(Academie, 1)

F = Application.CountIf(Range("H" & Ep(Le, 2) & ":H" & Ep(Le, 3)), "=" & Academie(La))

Set Cel = Range("H" & Ep(Le, 2) & ":H" & Ep(Le, 3)).Find(Academie(La))
If Not Cel Is Nothing Then D = Cel.Row

Lr = Ws.Range("A65536").End(xlUp).Row '1ère ligne coller

Range("B" & D & ":N" & D + F - 1).Copy Destination:=Ws.Range("A" & Lr)

Li = Ws.Range("A65536").End(xlUp).Row 'dernière ligne après coller

If Li > Lr Then Ws.Range("A" & Lr & ":M" & Li).Sort Key1:=Ws.Range("M" & D), Order1:=xlDescending

If Li - Lr > NbE Then
Li = Lr + NbE
Ws.Range("A" & Li & ":M" & Ws.Range("A65536").End(xlUp).Row).ClearContents
End If

Ws.Range("N" & Ws.Range("A65536").End(xlUp).Row + 1) = La
Next La

Next Le

With Ws
.Columns("I:L").Delete Shift:=xlToLeft
.Columns("B:F").Delete Shift:=xlToLeft
.Columns("E").ClearContents
.Rows(1).Insert
.Cells(1, 1) = "Dossard"
.Cells(1, 2) = "Académie"
.Cells(1, 3) = "Epreuve"
.Cells(1, 4) = "Points"
.Columns("A😀").AutoFit
End With

EpNumToText True

L = Ws.Range("A65536").End(xlUp).Row
Ws.Range("A1😀" & L).Sort Key1:=Ws.Range("B2"), Order1:=xlAscending, Header:=xlGuess

Application.ScreenUpdating = True

End Sub

'change numeric colonne I dans colonne N en texte:exemple 1 à 6=course

Private Sub CommandButton1_Click()

EpNumToText

End Sub

Private Sub CommandButton2_Click()

PerfClasser

End Sub

à bientôt

Re : classement

Bonjour

pour l'action "change colonne I" ça fonctionne

MAis le 2e bouton j'ai un message
erreur 1004- impossible de modifier une cellule fusionnée :

code où il y a le bug
Range("B" & D & ":N" & D + F - 1).Copy Destination:=Ws.Range("A" & Lr) en

merci
Jonpol

Re : classement

Jonpol

tu supprimes les cellules fusionnées
sélectionne la feuille,au dessus de 1(ligne) et à gauche de A(colonne)
ensuite menu éditon->effacer->tout
rmq:le code tiens compte du maximum par ep et est classé décroissant

à bientôt

Re : classement

Bonsoir
Ca marche mais c'est en colonne et pas en ligne 🙂 dans la feuille "toutes perfs"

J'ai pris une feuille resultats avec 6500 perfs et là ça ne marche à qu' 15% il m'en prend que 945 en feuille "toute perf"".

JonPol

Re : classement

Bonsoir
Normalement dans la feuilles "toutes perfs", il devraient y avoir toutes les perfs. OR il y a que les 14 perfs courses (classées décroissantes) et les 11 perfs (sauts), 7 perfs lancers et 0 relais
j'ai regardé le code et suivi ta logique.
Select Case Ep(Le, 1)
Case "course"
NbE = 15 (=ok)
Case "lancer"
NbE = 8 (= au lieu de 9)
Case "relais"
NbE = 1 (au lieu de 2)
Case "saut"
NbE = 12 (au lieu de 13)

MAis cela ne résoud que le probleme du 14/12/8/1
alors que l'on devrait avoir toutes les perfs c'est à dire
maxi courses =60 maxi sauts=30 , maxi lancers=30; maxi relais=30
le code ne devrait-il pas etre
Select Case Ep(Le, 1)
Case "course"
NbE = 61
Case "lancer"
NbE = 31
Case "relais"
NbE = 31
Case "saut"
NbE = 31

PUis avec ces perfs on doit en choisir : course=14; sauts=12, lancer=8 et relais=1.
Avec condition : Un dossard ne peut etre pris plus de 2 fois (2 courses ou 2 sauts, ou 2 lancers ou 1 saut 1 course, 1 saut 1 lancer, 1course 1 lancer, 1 lancer 1 saut)

qu'en penses tu?
merci
JonPol

Re : classement

Bonsoir

j'ai tenté avec maxi courses =61 maxi sauts=31 , maxi lancers=31; maxi relais=31 et ça marche.

Maintenant reste le plus dur...?
Comment récupérer les 14/12/8/1 perfs qui donneront le meilleur total avec la condition jamais plus de 2 fois le meme dossard dans l'équipe.?

Calculer toutes les combinaisons possibles et garder la meilleure?

merci
JonPol

Re : classement

bonjour Jonpol
j'ai mal compris les explications alors,dans la feuille toutes perfs, faut il garder la colonne i (ep) avec les chiffres.Je vais essayer avec maxi courses =61 maxi sauts=31 , maxi lancers=31; maxi relais=31
je suis commencé la 2ème feuille avec14/12/8/1 perfs ,j'en suis à rechercher les noms
après j'essaye de mettre les données en ligne
mets une feuille avec plus de données,svp(pour avoir plus de cas)
à bientôt

Re : classement

Bonjour

ci joint le fichier
Cijoint.fr - Service gratuit de dépôt de fichiers

JonPol