Bonjour,
J'ai créé un fichier excel qui me permet de faire un classement automatique pour mon club de poker.
Je cherche à affiner le tri mais c'est un peu particulier.
Si quelqu'un veut bien me donner un coup de main, je suis preneur.
Je récupère les données qui m'intéressent dans les feuilles de résultats et je les colle dans une feuille nommée "Classement final", puis je trie en fonction du total de point de chacun. Je récupère également le classement de chaque journée ( 8 tournois pour cette saison )
Mon problème se situe au niveau du départage des ex æquo.
Je souhaite trier les joueurs en fonction de leur meilleure perf.
Le fichier est trop gros pour être posté sur le forum. Donc je mets la partie de la macro qui m'intéresse.
>>
'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 colonnes de classement de chaque journée de classement final
Sheets("S2B1").Range("E8:E96").Copy
Sheets("Classement").Range("F2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B2").Range("E8:E96").Copy
Sheets("Classement").Range("G2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B3").Range("E8:E96").Copy
Sheets("Classement").Range("H2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B4").Range("E8:E96").Copy
Sheets("Classement").Range("I2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B5").Range("E8:E96").Copy
Sheets("Classement").Range("J2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B6").Range("E8:E96").Copy
Sheets("Classement").Range("K2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B7").Range("E8:E96").Copy
Sheets("Classement").Range("L2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B8").Range("E8:E96").Copy
Sheets("Classement").Range("M2").PasteSpecial Paste:=xlPasteValues
'copier les résultats dans la feuille de classement final
Sheets("TOTAL FINAL").Range("L2:L96").Copy
Sheets("Classement").Range("C2:C96").PasteSpecial Paste:=xlPasteValues
'copier les points de bonus dans la feuille de classement final
Sheets("TOTAL FINAL").Range("K2:K96").Copy
Sheets("Classement").Range("E2:E96").PasteSpecial Paste:=xlPasteValues
'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 score
Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' 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("D396"), Type:=xlFillDefault
'Copier la colonne des scores et la coller en valeur (collage spécial valeur)
Range("D296").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("D296").Select
Selection.Copy
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D296").Select
Selection.ClearContents
' supprimer les lignes entières ne comportant pas de Noms
Range("B2:B96").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' supprimer les lignes entières ne comportant pas de Résultats
' supprimer La colonne "D"
Columns("D").Delete Shift:=xlToLeft
Range("D11").Select
<
A votre bon coeur, si vous arrivez à comprendre mes attentes.
Merci d'avance.
J'ai créé un fichier excel qui me permet de faire un classement automatique pour mon club de poker.
Je cherche à affiner le tri mais c'est un peu particulier.
Si quelqu'un veut bien me donner un coup de main, je suis preneur.
Je récupère les données qui m'intéressent dans les feuilles de résultats et je les colle dans une feuille nommée "Classement final", puis je trie en fonction du total de point de chacun. Je récupère également le classement de chaque journée ( 8 tournois pour cette saison )
Mon problème se situe au niveau du départage des ex æquo.
Je souhaite trier les joueurs en fonction de leur meilleure perf.
Le fichier est trop gros pour être posté sur le forum. Donc je mets la partie de la macro qui m'intéresse.
>>
'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 colonnes de classement de chaque journée de classement final
Sheets("S2B1").Range("E8:E96").Copy
Sheets("Classement").Range("F2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B2").Range("E8:E96").Copy
Sheets("Classement").Range("G2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B3").Range("E8:E96").Copy
Sheets("Classement").Range("H2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B4").Range("E8:E96").Copy
Sheets("Classement").Range("I2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B5").Range("E8:E96").Copy
Sheets("Classement").Range("J2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B6").Range("E8:E96").Copy
Sheets("Classement").Range("K2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B7").Range("E8:E96").Copy
Sheets("Classement").Range("L2").PasteSpecial Paste:=xlPasteValues
Sheets("S2B8").Range("E8:E96").Copy
Sheets("Classement").Range("M2").PasteSpecial Paste:=xlPasteValues
'copier les résultats dans la feuille de classement final
Sheets("TOTAL FINAL").Range("L2:L96").Copy
Sheets("Classement").Range("C2:C96").PasteSpecial Paste:=xlPasteValues
'copier les points de bonus dans la feuille de classement final
Sheets("TOTAL FINAL").Range("K2:K96").Copy
Sheets("Classement").Range("E2:E96").PasteSpecial Paste:=xlPasteValues
'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 score
Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
' 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("D396"), Type:=xlFillDefault
'Copier la colonne des scores et la coller en valeur (collage spécial valeur)
Range("D296").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("D296").Select
Selection.Copy
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D296").Select
Selection.ClearContents
' supprimer les lignes entières ne comportant pas de Noms
Range("B2:B96").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' supprimer les lignes entières ne comportant pas de Résultats
' supprimer La colonne "D"
Columns("D").Delete Shift:=xlToLeft
Range("D11").Select
<
A votre bon coeur, si vous arrivez à comprendre mes attentes.
Merci d'avance.