Coup de pouce pour réalisation d'un classement

Le 23/03/2008 à 02:05

Bonjour,

J'ai réalisé un fichier qui me permet de classer en très peu de temps les participants à un Challenge de Pétanque. Je touche presque au but !

Mon problème est que tous les adhérents ne participent pas mais qu'ils apparaissent dans mon classement final.

Je voudrais savoir comment faire pour terminer ma macro. Il ne me reste plus qu'a supprimer les lignes des adhérents n'ayant participé à aucune journée du challenge.

Comment, à partir de Vis Bas, sélectionner toutes les lignes contenant une valeur précise ( en l'occurrence "0") dans une colonne donnée, afin de les supprimer.

J'ai placé des annotations dans la macro.

Si vous voulez des précisions, n'hésitez pas à me contacter.

En espérant avoir été assez clair et trouver une réponse pour surmonter ce problème.

Merci d'avance

Yul80

#################################################################

Sub Classement()

'

'copier les noms dans la feuille de classement final

Sheets("TOTAL FINAL").Select

Range("B2:B96").Select

Selection.Copy

Sheets("Classement").Select

Range("B2").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

'copier les résultats dans la feuille de classement final

Sheets("TOTAL FINAL").Select

Range("L2:L96").Select

Selection.Copy

Sheets("Classement").Select

Range("E2:E96").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

'copier les NBJJ ( Nombre de journées jouées ) dans la feuille de classement final

Sheets("TOTAL FINAL").Select

Range("K2:K96").Select

Selection.Copy

Sheets("Classement").Select

Range("C2:C96").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

'pour une matrice des lignes 2 à 112

'avec en colonne D un index des joueurs,

'en colonne B leur nom et

'en colonne C le rang que l'on va remplir automatiquement

'classer dans l'ordre alphabétique

Rows("2:96").Select

Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

'classer selon le score

Rows("2:96").Select

Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

'classer selon le NBJJ

Rows("2:96").Select

Selection.Sort Key1:=Range("E2"), Order1:=xlDescending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

' Mettre la suppression des ligne des non participants ici

' Mettre 1 au rang du premier en donnant comme rang le N° de ligne moins 1

Range("D2").Select

ActiveCell.FormulaR1C1 = "=ROW(RC[-1])-1"

' Au suivant mettre son N° de ligne -1 s'il est différent du précédent,

'sinon mettre comme le précédent

Range("D3").Select

ActiveCell.FormulaR1C1 = "=+IF(RC[-1]=R[-1]C[-1],R[-1]C,ROW(RC[-1])-1)"

'copier cette formule dans toute lma colonne score de la matrice

Range("D3").Select

Selection.AutoFill Destination:=Range("D3:D96"), Type:=xlFillDefault

'Copier la colonne des scores et la coller en valeur (collage spécial valeur)

Range("D2:D96").Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

'retrier les lignes en fonction de l'index des joueurs mais ce pourrait être par ordre alphabétique par exemple

Rows("2:96").Select

Application.CutCopyMode = False

Selection.Sort Key1:=Range("D3"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

Range("D3").Select

Range("D2:D96").Select

Selection.Copy

Range("A2").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Range("D2:D96").Select

Selection.ClearContents

Range("E2:E96").Select

Selection.ClearContents

End Sub

Le 23/03/2008 à 02:56

Bonjour,

ce qui me dérange dans ton code c'est que par moment, tu copies les nombres de journées jouées dans la colonne C, puis pour le tri par NBJJ, tu prends la colonne E...

sinon, regarde le code suivant, une ébauche :

Nota : les .select ne servent (pratiquement) à rien en VBA

Sub Classement()
'copier les noms dans la feuille de classement final

Sheets("TOTAL FINAL").Range("B2:B96").Copy
Sheets("Classement").Range("B2").PasteSpecial Paste:=xlPasteValues

'copier les résultats dans la feuille de classement final

Sheets("TOTAL FINAL").Range("L2:L96").Copy
Sheets("Classement").Range("E2:E96").PasteSpecial Paste:=xlPasteValues

'copier les NBJJ ( Nombre de journées jouées ) dans la feuille de classement final

Sheets("TOTAL FINAL").Range("K2:K96").Copy
Sheets("Classement").Range("C2:C96").PasteSpecial Paste:=xlPasteValues

Range("A2:E96").Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range("E2") _
        , Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending

' Remplacer les valeurs 0 par des cellules vides, puis supprimer les lignes entières

Range("C2:C96").Replace What:="0", Replacement:="", LookAt:=xlWhole
Range("C2:C96").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

' Mettre 1 au rang du premier en donnant comme rang le N° de ligne moins 1

Range("D2").FormulaR1C1 = "=ROW(RC[-1])-1"

Range("D3").FormulaR1C1 = "=IF(RC[-1]=R[-1]C[-1],R[-1]C,ROW(RC[-1])-1)"

'copier cette formule dans toute lma colonne score de la matrice

Range("D3").AutoFill Destination:=Range("D3:D96"), Type:=xlFillDefault

'Copier la colonne des scores et la coller en valeur (collage spécial valeur)

Range("A2:A96").Value = Range("D2:D96").Value

'retrier les lignes en fonction de l'index des joueurs mais ce pourrait être par ordre alphabétique par exemple

Range("D2:D96").ClearContents

Range("E2:E96").ClearContents

End Sub
Le 23/03/2008 à 10:55

Merci pour le coup de pouce.

J'ai retouché ma Macro de la manière suivante et ca marche.

##########################

Sub Classement()

'

'copier les noms dans la feuille de classement final

Sheets("TOTAL FINAL").Select

Range("B2:B96").Select

Selection.Copy

Sheets("Classement").Select

Range("B2").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

'copier les NBJJ dans la feuille de classement final

Sheets("TOTAL FINAL").Select

Range("L2:L96").Select

Selection.Copy

Sheets("Classement").Select

Range("E2:E96").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

'copier les résultats dans la feuille de classement final

Sheets("TOTAL FINAL").Select

Range("K2:K96").Select

Selection.Copy

Sheets("Classement").Select

Range("C2:C96").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

'pour une matrice des lignes 2 à 112

'avec en colonne A un index des joueurs,

'en colonne B leur nom et

'en colonne C le rang que l'on va remplir automatiquement

'classer dans l'ordre alphabétique

Rows("2:96").Select

Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

'classer selon le NBJJ puis selon le score

Rows("2:96").Select

Selection.Sort Key1:=Range("E2"), Order1:=xlDescending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

' Mettre la suppression des ligne des non participants ici

' Remplacer les valeurs 0 par des cellules vides, puis supprimer les lignes entières

Range("E2:E96").Replace What:="0", Replacement:="", LookAt:=xlWhole

Range("E2:E96").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

' Mettre 1 au rang du premier en donnant comme rang le N° de ligne moins 1

Range("D2").Select

ActiveCell.FormulaR1C1 = "=ROW(RC[-1])-1"

' Au suivant mettre son N° de ligne -1 s'il est différent du précédent,

'sinon mettre comme le précédent

Range("D3").Select

ActiveCell.FormulaR1C1 = "=+IF(RC[-1]=R[-1]C[-1],R[-1]C,ROW(RC[-1])-1)"

'copier cette formule dans toute lma colonne score de la matrice

Range("D3").Select

Selection.AutoFill Destination:=Range("D3:D96"), Type:=xlFillDefault

'Copier la colonne des scores et la coller en valeur (collage spécial valeur)

Range("D2:D96").Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

'retrier les lignes en fonction de l'index des joueurs mais ce pourrait être par ordre alphabétique par exemple

Rows("2:96").Select

Application.CutCopyMode = False

Selection.Sort Key1:=Range("D3"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

Range("D3").Select

Range("D2:D96").Select

Selection.Copy

Range("A2").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Range("D2:D96").Select

Selection.ClearContents

Range("E2:E96").Select

Selection.ClearContents

' supprimer les lignes entières ne comportant pas de Noms

Range("B2:B96").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

##############################

Par contre, je viens de penser à un truc.

Le challenge se déroule en 8 journées mais on prend que les 5 meilleures journées.

On doit également classer les gens en fonction de leur nombre de participation.

Le calcul du total des points est déjà fait sur les 5 meilleures journées sur 8.

Mais, par exemple, un joueur ayant fait 5 mauvaise journées doit être mieux classé qu'un joueurs n'ayant fait que 3 bonnes journées.

En gros, les classement doit s'effectuer de la manière suivante :

5 journées et plus puis en fonction du score.

4 journées puis en fonction du score.

3 journées puis en fonction du score.

2 journées puis en fonction du score.

1 journées puis en fonction du score.

Ma question est :

Comment sélectionner les lignes correspondant aux gens avec 5 participation et plus avant de les trier?

Je cherche de mon côté mais si vous pouvez me guider.

Merci

Yul80

Le 23/03/2008 à 11:16

Bonjour,

j'ai vu que tu continuais avec les .Select.....

Pour le classement, il te suffit de faire le tri avec pour première clé : le nombre de journées par ordre décroissant, deuxième clé le nombre de points en décroissant et troisième clé, les noms en croissant

Ce serait plus facile avec un fichier exemple, cela permettrait d'optimiser ton code

As-tu analysé le mien?

Le 23/03/2008 à 11:22

Oui mais certains classement ne se faisaient plus.

En fait, les .Select me permettent de voir en direct avec F8 ce qui se passe ! mais je suis plus que novice. J'en suis arrivé là avec de la curiosité et je suis assez content pour l'instant.

Pour ce qui est du fichier exemple, il est trop gros pour le poster sur le forum, si tu a une idée ?

mon adresse MSN est Yul80@hotmail.com.

Le 23/03/2008 à 11:53

Re-,

message envoyé en Message Privé

Le 23/03/2008 à 12:43

Re-,

j'ai complètement repensé ton code

Pour commencer, on détermine la plage à traiter par les 3 premières lignes (après Application.Screen...qui sert à figer l'écran lors du déroulement, pour la rapidité et le confort des yeux)

Avec celui-ci, on n'extrait que les personnes ayant participé à au moins une journée (même s'ils ont zéro point)

Pour cela, il faut que les en-têtes de ligne soient exactement les mêmes que dans la feuille Total Final

Ensuite, on met la formule, on trie avec les trois critères (NBJJ décroissant, Points décroissant et Noms croissant)

on remplace les formules par les valeurs

et voila....

le code :

Sub classement()
Application.ScreenUpdating = False
Dim pl As Range
Set pl = Sheets("TOTAL FINAL").Range("B1:L" & Sheets("TOTAL FINAL").Range("A65536").End(xlUp).Row)
pl.Name = "base"
[J2].FormulaR1C1 = "='TOTAL FINAL'!RC[2]>0"
Range("base").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("J1:J2"), CopyToRange:=Range("B1:D1"), Unique:=False
Range("A2").FormulaR1C1 = "=ROW(RC)-1"
Range("A3").FormulaR1C1 = "=IF(RC[2]=R[-1]C[2],R[-1]C,ROW(RC)-1)"
Range("A3").AutoFill Destination:=Range("A3:A" & [B65000].End(xlUp).Row), Type:=xlFillDefault
Range("A1:D" & [A65000].End(xlUp).Row).Sort Key1:=Range("D2"), Order1:=xlDescending, Key2:=Range _
        ("C2"), Order2:=xlDescending, Key3:=Range("B2"), Order3:=xlAscending, _
        Header:=xlGuess
Range("A2:A" & [A65000].End(xlUp).Row).Value = Range("A2:A" & [A65000].End(xlUp).Row).Value
[J2].ClearContents
Application.ScreenUpdating = True
End Sub
Le 24/03/2008 à 00:21

Chez moi, ton code ne marche pas.

Je dois juste mettre ton code à la place du mien ? ( copier/coller)

Cette ligne semble poser PB :

" Range("base").AdvancedFilter Action:=xlFilterCopy, _

CriteriaRange:=Range("J1:J2"), CopyToRange:=Range("B1:D1"), Unique:=False "

Elle est en jaune lors du débogage.

Pour ce qui est du classement, si deux joueurs ont un total identique de point sur leurs 5 meilleures journées, ce n'est pas le nombre de participation qui doit les départager.Ils sont ex-aequo. un point c'est tout. C'est l'ordre alphabétique qui les classe à partir de là. Dans ton choix, c'est le nombre de participation qui prime ?

En tous cas, merci beaucoup pour ton aide.

Je pensais que tu pourrais me dire comment faire une sélection des lignes correspondant aux joueurs ayant participé au moins à 5 journées dans la feuille de classement final, juste après avoir recopié les noms, les points et les NJJ. ( Dans le cas de l'utilisation de ma macro, bien sur)

Comment coder ca ?

Bien sur, une fois que tout sera ok, je supprimerai les .Select. Qui te déplaisent tant !

Merci

Le 24/03/2008 à 02:05

J'ai trouvé une astuce !

Je vais remplacer le NJJ supérieurs à "5" par "5" dans la colonne correspondante avant de trier par NJJ.

Ca marche nikel.

Merci pour votre aide.

Rechercher des sujets similaires à "coup pouce realisation classement"