En VBA, ne plus prendre en considération F ou M pour établir le classement
Bonsoir
J'aimerais rectifier les résultats de ma feuille "Pétanque Pts & Médailles" car je ne voudrais pas faire un classement qui différencie les hommes des femmes pour tous mes résultats, soit toutes les colonnes ==> "clt1", "clt2" & "clt3".
Exemples :
Donc je ne voudrais plus de classement différencié pour les 3 épreuves ==> "5 ateliers", "9 cibles" & "13 cibles"
Par exemple pour le "5 ateliers", le nouveau classement serait le suivant ==>
Selon le tableau en "clt1" ci-dessous SAID ne serait plus première mais 3ème
RODRIGUES 4ème et non 2ème
Chez les garçons, les 3ème deviennent 6ème...
etc, etc, etc, et sur tous les résultats
Ca va bien simplifier la procédure en question ci-dessous "Sub Medailles( )" mais je n'ose pas trop intervenir ==> Une idée ?
Déjà, il faudrait enlever tout ce qui concerne les sexes, pour le classement.
Je ne pense pas qu'il y ait besoin du classeur car toutes les infos sont présentes. Mais au cas où, je peux le fournir
Tous le noms de familles sont une invention afin de protéger l'identité de mes vrais sportifs
Merci bcp de vous être intéressés à ce sujet
Bonne soirée
Sub Medailles()
Dim Dict, i1, i2, i3, i4, sSexe, i As Integer, iOffset, Pts, N
Set Dict = CreateObject("scripting.dictionary")
iOffset = Range("tabel1").Row - 1
For i1 = 1 To 3
Select Case i1
Case 1
f_ = "MOD(IFERROR(AGGREGATE(15,6,(Tabel1[CLT1]+ROW(Tabel1[CLT1])/1000)/(Tabel1[Sexe]=#),@),0),1)*1000"
Set c = Range("tabel1[pts_1]")
Case 2
f_ = "MOD(IFERROR(AGGREGATE(15,6,(Tabel1[CLT2]+ROW(Tabel1[CLT2])/1000)/(Tabel1[Sexe]=#),@),0),1)*1000"
Set c = Range("tabel1[pts_2]")
Case 3
f_ = "MOD(IFERROR(AGGREGATE(15,6,(Tabel1[CLT3]+ROW(Tabel1[CLT3])/1000)/(Tabel1[Sexe]=#),@),0),1)*1000"
Set c = Range("tabel1[pts_3]")
End Select
For i2 = 1 To 2
sSexe = IIf(i2 = 1, "H", "F")
For i3 = 1 To 100
s = Replace(Replace(f_, "#", Chr(34) & sSexe & Chr(34)), "@", i3)
i4 = Evaluate(s)
If i4 = 0 Then Exit For
i = i4 - iOffset
Pts = c.Cells(i, 1).Value2
If Pts > 0 And Len(Pts) > 0 Then
'Debug.Print Pts
If Not Dict.exists(i) Then Dict(i) = Array(i4, Range("Tabel1[nom]").Cells(i, 1).Value2, Range("Tabel1[prenom]").Cells(i, 1).Value2, Range("Tabel1[sexe]").Cells(i, 1).Value2, Range("Tabel1[age]").Cells(i, 1).Value2, 0, 0, 0, 0)
'Debug.Print i, Range("Tabel1[nom]").Cells(i, 1).Value2, Range("Tabel1[prenom]").Cells(i, 1).Value2, Range("Tabel1[sexe]").Cells(i, 1).Value2, Range("Tabel1[age]").Cells(i, 1).Value2, 0, 0, 0, 0
itm = Dict(i)
itm(5) = Application.Max(Pts, itm(5)) 'itm(5) = Pts
If i1 = 1 Then itm(6) = Application.Max(Pts, itm(6))
If i1 = 2 Then itm(7) = Application.Max(Pts, itm(7)) 'itm(7) = IIf(i1 = 2, Pts, 0)
If i1 = 3 Then itm(8) = Application.Max(Pts, itm(8)) 'itm(8) = IIf(i1 = 3, Pts, 0)
Dict(i) = itm
End If
Next
Next
Next
N = Dict.Count
If N = 1 Then Dict.Add "dummy", Dict.items()(0)
b = Application.EnableEvents 'état des évenements (false ou true)
Application.EnableEvents = False 'désactiver
With Range("tabel6").ListObject
.Parent.Protect "seb", userinterfaceonly:=True 'enlever la protection pour la feuille pour VBA **********
If N = 0 And .ListRows.Count > 0 Then .DataBodyRange.Delete: Exit Sub
If .ListRows.Count = 0 Then .ListRows.Add
.DataBodyRange.Resize(Dict.Count, 9).Value = Application.Index(Dict.items, 0, 0)
If .ListRows.Count > N Then .DataBodyRange.Offset(N).Resize(.ListRows.Count - N).Delete
With .Range
.Sort .Cells(1, 4), xlAscending, , .Cells(1, 6), xlDescending, Header:=xlYes
End With
End With
Application.EnableEvents = b 'remettre dans l'état de 10 lignes plus haut
End SubBonjour
Tu devrais joindre ton fichier...
Bye !
Bonsoir et of course gmb, merci de t'y intéresser
Sur le bouton "Débloquer ou Quitter", tapez vodoraix pour tt débloquer.
Et mot de passe pour débloquer les feuilles ==> seb
re,
le fichier est encore "...vierge-6" et ne pas le 7, mais si tu copies la macro "Medailles2" de ce fichier vers ton "vierge-7" + les formules des colonnes J:L, cela suffira !
Super et merci beaucoup Bart', une fois de plus
J'ai donc tout copié comme tu m'as dit de faire (formules et sub) et j'ai mis en pause le sub Medailles pour mettre le sub Medailles2 en macro sur le bouton de la feuille "Pétanque Pts..."
Cette feuille est parfaite sur le classement, c'est comme je voulais, merci
Voir message suivant ==>
J'ai réfléchi un bon moment pour comprendre et l'erreur vient du tableau sur la feuille "Pétanque Pts & Médailles" en colonne A, dans lequel les numéros de lignes ne sont pas les bons.
Donc l'erreur ne vient pas des formules sur la feuille "STATS" mais surement du sub Medailles2 ==>
Mais je n'arrive pas à savoir où ces numéros de lignes sont enregistrés...
Pour comparer avec le sub Medailles qui fonctionnait à ce niveau, il se trouve sur mon premier message, tout en haut...
Sub Medailles2()
Dim Dict, i, j, i1, i2, i3, i4, sSexe, iOffset, Pts, N, Arr, Arr1
With Range("Tabel1").ListObject
i1 = .ListColumns("Pts_1").Index
i2 = .ListColumns("Pts_2").Index
i3 = .ListColumns("Pts_3").Index
Arr = .DataBodyRange.Value2
ReDim Arr1(1 To UBound(Arr), 1 To 9)
For i = 1 To UBound(Arr)
For j = 1 To 4
Arr1(i, j) = Arr(i, j)
Next
Arr1(i, 5) = Arr(i, 7)
Arr1(i, 7) = Val(Arr(i, i1))
Arr1(i, 8) = Val(Arr(i, i2))
Arr1(i, 9) = Val(Arr(i, i3))
Arr1(i, 6) = Application.Max(Arr1(i, 7), Arr1(i, 8), Arr1(i, 9))
Next
End With
N = UBound(Arr1)
b = Application.EnableEvents 'état des évenements (false ou true)
Application.EnableEvents = False 'désactiver
With Range("tabel6").ListObject
.Parent.Unprotect "seb" 'enlever la protection pour la feuille **********
If N = 0 And .ListRows.Count > 0 Then 'aucun match et le TS n'est pas vide
.DataBodyRange.Delete 'vider le TS
Else
If .ListRows.Count = 0 Then .ListRows.Add 'TS est vide, alors ajoutez la première ligne
.DataBodyRange.Resize(UBound(Arr1), UBound(Arr1, 2)).Value = Arr1 'copier contenu du dictionaire dans le TS
If .ListRows.Count > N Then .DataBodyRange.Offset(N).Resize(.ListRows.Count - N).Delete 'supprimer toutes les lignes en trop
With .Range 'trier le TS (pour cecie, il faut vraiment enlever la protection, donc c'est fait 5 lignes en haut)
.Sort .Cells(1, 4), xlAscending, , .Cells(1, 6), xlDescending, Header:=xlYes
End With
End If
.Parent.Protect "seb" 'on a enlevé la protection, donc ici remettre la protection**********
End With
Application.EnableEvents = b 'remettre dans l'état de 10 lignes plus haut
End SubMerci pour votre aide
Bonne journée et profitez bien de ce jour férié
With Range("Tabel1").ListObject
i1 = .ListColumns("Pts_1").Index 'N° colonne Pts1
i2 = .ListColumns("Pts_2").Index 'idem
i3 = .ListColumns("Pts_3").Index
Arr = .DataBodyRange.Value2 'lire dans matrice
ReDim Arr1(1 To UBound(Arr), 1 To 9) 'créer matrice pour les résultats
For i = 1 To UBound(Arr) 'boucler les personnes du tabel1
For j = 1 To 4 '4 premières colonnes de la nouvelle matrice = 4 premières colonnes de tabel1
Arr1(i, j) = Arr(i, j) 'donc rank, nom, prénom et sexe
Next
Arr1(i, 5) = Arr(i, 7) 'age
Arr1(i, 7) = Val(Arr(i, i1)) 'pts1
Arr1(i, 8) = Val(Arr(i, i2)) 'pts2
Arr1(i, 9) = Val(Arr(i, i3)) 'pts3
Arr1(i, 6) = Application.Max(Arr1(i, 7), Arr1(i, 8), Arr1(i, 9)) 'max des pts
Next
End Withcomme tu peux voir dans la partie "for j=1 to 4 ..." les 4 premières colonnes (rank, nom, prenom, sexe) de "tabel1" sont les mêmes pour le "tabel6". C'est le rank que tu veux changer à .... ?
For i = 1 To UBound(Arr) 'boucler les personnes du tabel1
Arr1(i,1)= "????" 'première colonne à assigner
For j = 2 To 4 '4 premières colonnes de la nouvelle matrice = 4 premières colonnes de tabel1
Arr1(i, j) = Arr(i, j) 'donc rank, nom, prénom et sexe
Next
... Bonjour Bart' et merci beaucoup
C'est pas le rank mais le numéro de la ligne qui est repris dans le tableau STATS :
CCCCC qui est première femme en ligne n°9 devrait avoir 9 (et non 2 comme indiqué) en P6 du tableau sur la feuille "STATS"
Merci Bart' :-))))
re,
Arr1(i,1)= .range.row+i
'le "with" précédent, c'est "Range("Tabel1").ListObject", donc la ligne de l'entête du TS + i = numéro de la ligne de la feuille
Bonjour Bart' & merci beaucoup !!!!!!!!!!!!!!!!
Jamais de la vie, je n'aurais pu trouver tes lignes de programmation ==> Malgré tes explications, qui sont détaillées, et compréhensibles, j'y serais jamais arrivé
Tout fonctionne absolument à merveille !!!!
Tu es trop fort
_____________________________________
Y'a un minuscule détail, c'est que lorsque je remets à zéro toutes les perfs des sportifs à la pétanque, j'ai le tableau qui reste rempli.
Toute dernière chose ==> Peux-tu faire en sorte, stp, que lorsque un sportif n'a plus ses perfs, que sa ligne soit effacée
D'ailleurs, dans ce tableau, il devrait être vide de lignes car plus de perfs...
Le code VBA du sub :
Sub Medailles2()
Dim Dict, i, j, i1, i2, i3, i4, sSexe, iOffset, Pts, N, arr, Arr1
With Range("Tabel1").ListObject
i1 = .ListColumns("Pts_1").Index 'N° colonne Pts1
i2 = .ListColumns("Pts_2").Index 'idem
i3 = .ListColumns("Pts_3").Index
arr = .DataBodyRange.Value2 'lire dans matrice
ReDim Arr1(1 To UBound(arr), 1 To 9) 'créer matrice pour les résultats
For i = 1 To UBound(arr) 'boucler les personnes du tabel1
Arr1(i, 1) = .Range.Row + i 'première colonne à assigner
For j = 2 To 4 '4 premières colonnes de la nouvelle matrice = 4 premières colonnes de tabel1
Arr1(i, j) = arr(i, j) 'donc rank, nom, prénom et sexe
Next
Arr1(i, 5) = arr(i, 7) 'age
Arr1(i, 7) = Val(arr(i, i1)) 'pts1
Arr1(i, 8) = Val(arr(i, i2)) 'pts2
Arr1(i, 9) = Val(arr(i, i3)) 'pts3
Arr1(i, 6) = Application.Max(Arr1(i, 7), Arr1(i, 8), Arr1(i, 9)) 'max des pts
Next
End With
N = UBound(Arr1)
b = Application.EnableEvents 'état des évenements (false ou true)
Application.EnableEvents = False 'désactiver
With Range("tabel6").ListObject
.Parent.Unprotect "seb" 'enlever la protection pour la feuille **********
If N = 0 And .ListRows.Count > 0 Then 'aucun match et le TS n'est pas vide
.DataBodyRange.Delete 'vider le TS
Else
If .ListRows.Count = 0 Then .ListRows.Add 'TS est vide, alors ajoutez la première ligne
.DataBodyRange.Resize(UBound(Arr1), UBound(Arr1, 2)).Value = Arr1 'copier contenu du dictionaire dans le TS
If .ListRows.Count > N Then .DataBodyRange.Offset(N).Resize(.ListRows.Count - N).Delete 'supprimer toutes les lignes en trop
With .Range 'trier le TS (pour cecie, il faut vraiment enlever la protection, donc c'est fait 5 lignes en haut)
.Sort .Cells(1, 4), xlAscending, , .Cells(1, 6), xlDescending, Header:=xlYes
End With
End If
.Parent.Protect "seb" 'on a enlevé la protection, donc ici remettre la protection**********
End With
Application.EnableEvents = b 'remettre dans l'état de 10 lignes plus haut
End SubEncore mille mercis Bart' ==> Jij hebt op alles een antwoord !
Et promis, sur ce classeur, je n'embêterai plus personne car il est au top, grâce à toi à 90%
Je regarde souvent tes interventions sur d'autres sujets, et tes connaissances sont impressionnantes !!!
Bonne soirée mon champion
Sub Medailles2()
Dim Dict, i, j, i1, i2, i3, i4, sSexe, iOffset, Pts, N, Arr, Arr1, LO
With Range("Tabel1").ListObject
i1 = .ListColumns("Pts_1").Index 'N° colonne Pts1
i2 = .ListColumns("Pts_2").Index 'idem
i3 = .ListColumns("Pts_3").Index
Arr = .DataBodyRange.Value2 'lire dans matrice
ReDim Arr1(1 To UBound(Arr), 1 To 9) 'créer matrice pour les résultats
For i = 1 To UBound(Arr) 'boucler les personnes du tabel1
For j = 1 To 4 '4 premières colonnes de la nouvelle matrice = 4 premières colonnes de tabel1
Arr1(i, j) = Arr(i, j) 'donc rank, nom, prénom et sexe
Next
Arr1(i, 5) = Arr(i, 7) 'age
Arr1(i, 7) = Val(Arr(i, i1)) 'pts1
Arr1(i, 8) = Val(Arr(i, i2)) 'pts2
Arr1(i, 9) = Val(Arr(i, i3)) 'pts3
Arr1(i, 6) = Application.Max(Arr1(i, 7), Arr1(i, 8), Arr1(i, 9)) 'max des pts
Next
End With
N = UBound(Arr1) 'nombre de joueurs dans tabel1
b = Application.EnableEvents 'état des évenements (false ou true)
Application.EnableEvents = False 'désactiver
Set LO = Range("tabel6").ListObject
With LO
.Parent.Unprotect "seb" 'enlever la protection pour la feuille **********
If N = 0 And .ListRows.Count > 0 Then 'aucun joueur et le TS n'est pas vide
.DataBodyRange.Delete 'vider le TS
Else
If .ListRows.Count = 0 Then .ListRows.Add 'TS est vide, alors ajoutez la première ligne
.DataBodyRange.Resize(UBound(Arr1), UBound(Arr1, 2)).Value = Arr1 'copier contenu de la matrice Arr1 dans le TS
If .ListRows.Count > N Then .DataBodyRange.Offset(N).Resize(.ListRows.Count - N).Delete 'supprimer toutes les lignes en trop
With .Range
.Sort .Cells(1, 6), xlDescending, Header:=xlYes 'trier le tableau avec la colonne points maximal descendante, sexe n'a plus d'importance
N = WorksheetFunction.CountIf(LO.ListColumns("Pts").DataBodyRange, 0) 'maintenant N est le nombre de joueurs avec 0 points maximal
If N > 0 Then 'il y a des joueurs avec 0 comme points maximal
r = Application.IfError(Application.Match(0, LO.ListColumns("Pts").DataBodyRange, 0), 0) 'r=index de la première listrow avec points max = 0
If r > 0 Then LO.DataBodyRange.Offset(r - 1).Resize(N).Delete 'supprimer les lignes avec points max=0
End If
End With
End If
If LO.ListRows.Count = 0 Then MsgBox "VIDE !!!!"
.Parent.Protect "seb" 'on a enlevé la protection, donc ici remettre la protection**********
End With
Application.EnableEvents = b 'remettre dans l'état de 10 lignes plus haut
End SubParfait de chez parfait !!!!!!
J'ai juste remis les 2 lignes que tu m'avais proposées et qui n'étaient pas dans ce nouveau code ==> Et hopppppp, c'est exactement ce que j'espérais !!!!
Arr1(i, 1) = .Range.Row + i 'première colonne à assigner
For j = 2 To 4 '4 premières colonnes de la nouvelle matrice = 4 premières colonnes de tabel1Tu m'as fait un chef d'oeuvre Bart' !!!
Je vais essayer de faire aussi bien pour l'autre classeur et événement sportif (en recopiant beaucoup de tes sub) ==> Le challenge National avec mes 10 épreuves...
Bonne soirée