Classement Tableau macro
Bonjour à toutes et tous
Pourriez vous m'aider à créer une macro pour trier un tableau (synthèse) de façon à lister
les coureurs d'une liste sur un tableau récapitulatif répondant aux critères suivants :
1/ Seules, les équipes ayant au moins trois coureurs seront classées
2/ Seuls, les points des trois meilleurs de la même équipe seront comptabilisés
3/ le classement sera fait par ordre décroissant
Les deux premiers critères doivent pouvoir être modifiés (valeur de 3 actuellement)
Ci joint fichier pour une meilleure compréhension
Avec tout mes remerciements anticipés
Bonjour,
Tu truques
J'ai rétabli ça pour commencer !
A+
Je veux bien mettre une autre ville !!! LOL
Je crois que les commentaires que tu ne devrais pas manquer de demander m'ont pris plus de temps qu'écrire la macro...
Sub ClassementEquipe()
Dim d As Object, TR(), tmp(), k, pts, Nbm%, Nbp%, n%, i%, j%
Set d = CreateObject("Scripting.Dictionary")
n = 8 'ligne précédant la ligne de départ
With Worksheets("BF")
' Constitution d'un 'dictionnaire' des équipes
'la valeur de l'élément 'équipe' est une concaténation des points de
'chaque équipier séparés par des points-virgule,
'ce pourquoi on teste à chaque ligne si l'élément 'équipe' existe
'car à partir du 2e équipier la valeur de l'élément est à recomposer...
' NB- On balaie avec Do... en raison de formules au-delà du nombre...
Do While .Cells(n + 1, 5).Value <> ""
n = n + 1
If d.exists(.Cells(n, 5).Value) Then
pts = d(.Cells(n, 5).Value)
pts = pts & ";" & Val(.Cells(n, 8))
d(.Cells(n, 5).Value) = pts
Else
' NB-le ';' en tête de la chaîne permettra de transformer la chaîne
'en tableau avec un élément de plus que d'équipier, mais comme le
'1er indice est 0, l'indice le plus élevé de chaque élément dico
' correspondra au nombre d'équipiers
d(.Cells(n, 5).Value) = ";" & Val(.Cells(n, 8))
End If
Loop
' Variables NombreMini et NombrePointsEnCompte
Nbm = .Range("K6"): Nbp = .Range("M6")
' Effacement zone de résultats
.Range("J9").Resize(n, Nbp + 2).ClearContents
End With
' Parcours des clés de dico créées
For Each k In d.keys
pts = Split(d(k), ";") 'on extrait la valeur de l'élément sous forme de tableau
If UBound(pts) < Nbm Then 'si le nb d'équipiers est inférieur au mini
d.Remove (k) 'on supprime l'élément
Else
'sinon, on trie les points des équipiers par ordre décroissant
For i = 1 To UBound(pts) - 1
For j = i + 1 To UBound(pts)
If CInt(pts(j)) > CInt(pts(i)) Then
pts(0) = pts(j): pts(j) = pts(i): pts(i) = pts(0)
End If
Next j
Next i
n = 0 'on réinitialise une variable pour l'utiliser pour calcul du total
For i = 1 To Nbp 'boucle sur les points à prendre en compte
n = n + CInt(pts(i)) 'total...
pts(0) = n 'insertion total en 1er élément du tableau points de l'équipe
Next i
If UBound(pts) > Nbp Then 's'il y a des équipiers non retenus pour points
For i = Nbp + 1 To UBound(pts)
pts(i) = Chr(135) 'on substitue aux points un caractère atypique
'NB-le car. 135 est une double-croix (2 + superposés)
Next i
End If
' On rétablit le tableau de point de l'équipe en chaîne en y supprimant
'les couples caract.135 et point-virgule,
'et on réaffecte cette chaîne épurée à l'élément dico traité
pts = Replace(Join(pts, ";"), ";" & Chr(135), ""): d(k) = pts
End If
Next k
' On affecte le nb d'équipes (à résultat) dans une variable
'on redimensionne un tableau de résultats : nb lignes=nb équipes, nb colonnes=
'nb d'équipiers à points retenus + 2 (total et nom équipe)
'réinitialisation d'une variable pour utilisation dans la boucle suivante
n = d.Count: ReDim TR(1 To n, 1 To Nbp + 2): j = 0
'Re-parcours des clés de dico
For Each k In d.keys
'Incrémentation de la variable pour servir chaque ligne du tableau résultat
'affectation du nom équipe en 1re colonne (nom=clé élément dico)
're-extraction de la valeur en tableau (tableau point)
'affectation du total (1er élément tableau points) à la dernière colonne
j = j + 1: TR(j, 1) = k: pts = Split(d(k), ";"): TR(j, Nbp + 2) = CInt(pts(0))
'affectation des points équipiers aux colonnes intermédiaires
For i = 1 To Nbp
TR(j, i + 1) = CInt(pts(i))
Next i
Next k
' Dimensionnement d'un tableau temporaire sur le nb de colonnes du tableau
'résultats (pour servir au tri du tableau résultat)
ReDim tmp(1 To Nbp + 2)
' Tri tableau résultats par totaux décroissants
For i = 1 To n - 1
For j = i + 1 To n
If TR(j, Nbp + 2) > TR(i, Nbp + 2) Then
For k = 1 To Nbp + 2
tmp(k) = TR(j, k): TR(j, k) = TR(i, k): TR(i, k) = tmp(k)
Next k
End If
Next j
Next i
' Affectation du tableau résultats à la plage de résultats
Worksheets("BF").Range("J9").Resize(n, Nbp + 2).Value = TR
End Sub...le fichier arrive.
Efface manuellement pour mieux voir au test (bouton Tester).
MFERRAND me fait penser à Maréchal FERRAND
et , du coup, quel savoir "FER"
Ca fonctionne super
Petit Bémol : si je modifie le nombre de coureurs mini formant une équipe, ça beugue
Désolé pour cette petite anomalie
Avec mes plus sincères remerciements
Pas de bogue en ce qui me concerne !
J'ai passé mini à deux et points à 2 (le nombre d'équipiers pris en compte pour les points ne pouvant évidemment pas être supérieur au nombre d'équipiers minimum requis), ça modifie le classement...
J'ai passé mini à 4, en laissant points à 3. Une seule équipe est classée.
Il n'y a que l'effacement qui n'est pas complet lorsqu'on diminue le nombre, mais cela pourrait s'ajuster...
Après plusieurs tests, je me colle une baffe !!
En effet, on ne peut pas admettre les points de 3 pour un nombre de coureurs limité à 2 !!!!
J'ai donc mis 2 et 2 et ça fonctionne !!
Pourrait-on éviter que la somme (dans ce cas de 2 et 2) reste dans la colonne Somme ?
C'est l'effacement qui n'est pas complet car je l'ai aligné sur le nb de joueurs à points +2.
Donc quand tu diminues tu perds une colonne, qui n'est pas effacée...
Il y a aussi l'en-tête (elle était préexistante et je ne m'en suis pas occupée). Elle ne s'adapte donc pas automatiquement.
On peut faire... mais là c'est pause !
Est-ce que as un mini et un maxi à prendre en compte pour les points comme fourchette dont tu ne déborderas pas ?
Non, pas de mini ni de maxi !
As tu vu ma question sur les éventuelles feuilles des autres catégories que je souhaite ajouter !
Ne pourrais-je pas utiliser la mêmme macro pour des feuilles de même structure mais nommées différement
Bonne pause ou pose
Cordialement
Quelques aménagements :
- révision des largeurs de colonnes : très légèrement sur la partie A à H (plus pour régler l'affichage à partir de J sur mon écran !!
) et J à Z pour unifier les largeur de K à Z (je vais jusqu'à Z pour avoir de la marge et ne plus avoir à retoucher) - suppression quadrillage sur la zone J8:Z45 et couleur orange sur J8:Z8
- MFC qui met bordure sur J8:Z45, si cellule pas vide (quadrillage ajusté au tableau résultats)
- MFC couleur orange sur J8:Z8, couleur en-tête tableau résultats.
Mise en place proc. évènementielle Change qui se lance si M6 (nb d'équipiers à points pris en compte) est modifiée :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim etR(), Nbeq%, i%, j%
If Target.Address = "$M$6" Then
j = Me.Range("J8").End(xlToRight).Column - 10
If Me.Range("J9") <> "" Then i = Me.Range("J8").End(xlDown).Row - 8
Me.Range("K8").Resize(, j).ClearContents
If i > 0 Then Me.Range("J9").Resize(i, j + 1).ClearContents
Nbeq = Target.Value: ReDim etR(1 To Nbeq + 1)
For i = 1 To Nbeq
etR(i) = "Points du " & i & "e"
Next i
etR(1) = etR(1) & "r": etR(UBound(etR)) = "Total points"
Me.Range("K8").Resize(, Nbeq + 1).Value = etR
End If
End SubLorsqu'on modifiera M6, cette procédure effacera le tableau, y compris l'entête, sauf la cellule J8 (qui reste constante), et rétablit une en-tête correspondant au nombre d'équipiers défini en M6.
On évite ainsi le problème de valeurs résiduelles antérieures non effacées dans le tableau lors d'un nouveau classement lorsqu'on diminue le nombre d'équipier par rapport à la situation précédente.
L'effacement dans la procédure de classement demeure, il conserve son utilité lorsqu'on ne change pas le nombre d'équipiers.
Autres aménagements :
• Modules : rien ne justifie la présence de plusieurs modules standard. J'ai donc rassemblé toutes les procédures dans un seul module... J'en ai toutefois conservé 2 : un pour les procédures écrites en VBA et Module2 pour les procédures en totalité ou en partie enregistrées, dont j'oserai dire qu'elles ne sont pas écrites !, en attendant de les réécrire (en VBA
Par réécrire, j'entends : en supprimer tout Select, Selection, Activate ou action parasite apparentée, en supprimer les autres éléments inutiles, doter les expressions de qualificateurs d'objets, modifier le copier-coller au profit d'une méthode d'affectation VBA quand le copier-coller ne s'impose pas (ce qui est rare !), Substituer la méthode de tri Range.Sort à la méthode Worksheet.Sort systématiquement fourguée par l'enregistreur, utiliser tableaux, boucles, etc. (outils hors de portée de l'enregistreur) chaque fois que cela améliorera le code...
Le problème : La proc. Tri concerne visiblement un feuille non présente dans le classeur. Par ailleurs on ne sait s'il s'agit de procédure ponctuelles non destinées à de nouvelles utilisations (qu'il suffit alors de supprimer) ou de procédures à rendre pérennes (en les affectant à un bouton après révision).
• Divers : la mention en BF : A65536 ? Je n'ai pas détecté son utilité, mais si elle sert, il a sûrement toujours une autre méthode pour parvenir au même résultat !
J'ai modifié la définition de la plage Criteres (il n'est jamais conseillé de nommer une colonne entière...). Utilisant un tableau Excel, celui-ci est nommé automatiquement par Excel : par décalage de ce tableau, on obtient une définition de Criteres à partir de E3 correspondant à la partie de colonne incluse dans la liste.
• Pour généraliser les procédures à plusieurs feuilles (ne figurant pas), il faut les informations afférentes à la configuration d'ensemble finale et à la façon dont est utilisé le classeur.
Cordialement.