XL 2019 Classement par critere

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
L

LE BLEVEC

XLDnaute Junior
Bonjour
Faire un classement
en prenant que les 3 premier de chaque catégorie et rajouter 1-2-3, si que 1 dans la catégorie mettre 1 si que 2 mettre 1-2
et ça sur tout
je les ai déja trié par epreuve, categorie et point
mais apres je ne sais pas faire
j'ai mis un exemple a droite
je souhaiterais avec formules
je joint le fichier
merci de votre aide
 

Pièces jointes

Trier par date Trier par votes
Bonsoir à tous, et meilleurs vœux pour 2025,

Une autre proposition Power Query pour gérer les ex aequo potentiels (classement par ordre alphabétique).


PowerQuery: 
let
A = Excel.CurrentWorkbook(){[Name="Tableau1"]}[Content],
B = (x)=> Table.SelectColumns(Table.Sort(Table.FirstN(Table.AddRankColumn(x, "Id", {"Total",1}, [RankKind = 1]),3), {{"Id", 0}, {"Nom",0}}), {"Id"} & Table.ColumnNames(A)),
C = Table.Combine(Table.RemoveLastN(Table.Group(A, {"Catégorie E", "Epreuve"}, {"x", B}))[x])
in C
 
Vote positif 1 Vote négatif
job75 à dit:
Bonjour le forum,

Voyez le fichier .xlsm joint avec cette macro affectée au bouton :
VB: 
Sub Classer()
Dim d As Object, lig&, i&, crit$
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
[H:N].Clear 'RAZ
With [A1].CurrentRegion
    .Columns(6).NumberFormat = "0.0"
    .Columns(6).Replace ".", ".", xlPart 'convertit la colonne
    .Sort .Columns(3), xlAscending, .Columns(4), , xlAscending, .Columns(6), xlDescending, Header:=xlYes 'tri sur 3 colonnes
    .Columns(5).Insert xlToRight 'colonne auxiliaire
    .Columns(5) = "=RC[-2]&RC[-1]"
    .Columns(5) = .Columns(5).Value 'supprime les formules
    lig = 1
    For i = 2 To .Rows.Count
        crit = .Cells(i, 3) & .Cells(i, 4)
        If .Cells(i, 3) <> "" And Not d.exists(crit) Then
            d(crit) = ""
            .AutoFilter 5, crit 'filtre automatique
            .Copy .Cells(lig, 10) 'copier-coller
            .AutoFilter 'ôte le filtre
            .Cells(lig, 10).Resize(, 7).Clear 'supprime les titres
            .Cells(lig + 1, 10).CurrentRegion.Resize(, 7).Offset(3).Clear 'ne garde que 3 lignes
            .Cells(lig + 1, 9) = 1
            If .Cells(lig + 2, 10) <> "" Then .Cells(lig + 2, 9) = 2
            If .Cells(lig + 3, 10) <> "" Then .Cells(lig + 3, 9) = 3
            lig = lig + Application.Max(.Cells(lig + 1, 9).Resize(3)) + 1
        End If
    Next
    .Columns(14).Delete xlToLeft
    .Columns(5).Delete xlToLeft 'supprime la colonne auxiliaire
End With
End Sub
Je n'ai pas cherché à optimiser la rapidité car a priori le nombre de lignes n'est pas très grand.

A+
Cliquez pour agrandir...
job75 à dit:
Bonjour le forum,

Voyez le fichier .xlsm joint avec cette macro affectée au bouton :
VB: 
Sub Classer()
Dim d As Object, lig&, i&, crit$
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
[H:N].Clear 'RAZ
With [A1].CurrentRegion
    .Columns(6).NumberFormat = "0.0"
    .Columns(6).Replace ".", ".", xlPart 'convertit la colonne
    .Sort .Columns(3), xlAscending, .Columns(4), , xlAscending, .Columns(6), xlDescending, Header:=xlYes 'tri sur 3 colonnes
    .Columns(5).Insert xlToRight 'colonne auxiliaire
    .Columns(5) = "=RC[-2]&RC[-1]"
    .Columns(5) = .Columns(5).Value 'supprime les formules
    lig = 1
    For i = 2 To .Rows.Count
        crit = .Cells(i, 3) & .Cells(i, 4)
        If .Cells(i, 3) <> "" And Not d.exists(crit) Then
            d(crit) = ""
            .AutoFilter 5, crit 'filtre automatique
            .Copy .Cells(lig, 10) 'copier-coller
            .AutoFilter 'ôte le filtre
            .Cells(lig, 10).Resize(, 7).Clear 'supprime les titres
            .Cells(lig + 1, 10).CurrentRegion.Resize(, 7).Offset(3).Clear 'ne garde que 3 lignes
            .Cells(lig + 1, 9) = 1
            If .Cells(lig + 2, 10) <> "" Then .Cells(lig + 2, 9) = 2
            If .Cells(lig + 3, 10) <> "" Then .Cells(lig + 3, 9) = 3
            lig = lig + Application.Max(.Cells(lig + 1, 9).Resize(3)) + 1
        End If
    Next
    .Columns(14).Delete xlToLeft
    .Columns(5).Delete xlToLeft 'supprime la colonne auxiliaire
End With
End Sub
Je n'ai pas cherché à optimiser la rapidité car a priori le nombre de lignes n'est pas très grand.

A+
Cliquez pour agrandir...
Bonjour JOB et meilleurs vœux
si possible en colonne C inverser le trier (de Z à A)
et aussi si c'est possible de mettre le total de l'équipe
j'ai fait un petit exemple en colonne O
merci
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour LE BLEVEC,

Bonne année à vous aussi.
VB: 
Sub Classer()
Dim d As Object, lig&, i&, crit$, h As Byte
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
[H:O].Clear 'RAZ
With [A1].CurrentRegion
    .Columns(6).NumberFormat = "0.0"
    .Columns(6).Replace ".", ".", xlPart 'convertit la colonne
    .Sort .Columns(3), xlDescending, .Columns(4), , xlAscending, .Columns(6), xlDescending, Header:=xlYes 'tri sur 3 colonnes
    .Columns(5).Insert xlToRight 'colonne auxiliaire
    .Columns(5) = "=RC[-2]&RC[-1]"
    .Columns(5) = .Columns(5).Value 'supprime les formules
    lig = 1
    For i = 2 To .Rows.Count
        crit = .Cells(i, 3) & .Cells(i, 4)
        If .Cells(i, 3) <> "" And Not d.exists(crit) Then
            d(crit) = ""
            .AutoFilter 5, crit 'filtre automatique
            .Copy .Cells(lig, 10) 'copier-coller
            .AutoFilter 'ôte le filtre
            .Cells(lig, 10).Resize(, 7).Clear 'supprime les titres
            .Cells(lig + 1, 10).CurrentRegion.Resize(, 7).Offset(3).Clear 'ne garde que 3 lignes
            .Cells(lig + 1, 9) = 1
            If .Cells(lig + 2, 10) <> "" Then .Cells(lig + 2, 9) = 2
            If .Cells(lig + 3, 10) <> "" Then .Cells(lig + 3, 9) = 3
            h = Application.Max(.Cells(lig + 1, 9).Resize(3))
            .Cells(lig + 1, 17) = "=SUM(RC[-1]:R[" & h - 1 & "]C[-1])"
            lig = lig + h + 1
        End If
    Next
    .Columns(14).Delete xlToLeft
    .Columns(5).Delete xlToLeft 'supprime la colonne auxiliaire
End With
End Sub
Edit : [H:O].Clear 'RAZ

A+
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
job75 à dit:
Bonjour LE BLEVEC,

Bonne année à vous aussi.
VB: 
Sub Classer()
Dim d As Object, lig&, i&, crit$, h As Byte
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
[H:N].Clear 'RAZ
With [A1].CurrentRegion
    .Columns(6).NumberFormat = "0.0"
    .Columns(6).Replace ".", ".", xlPart 'convertit la colonne
    .Sort .Columns(3), xlDescending, .Columns(4), , xlAscending, .Columns(6), xlDescending, Header:=xlYes 'tri sur 3 colonnes
    .Columns(5).Insert xlToRight 'colonne auxiliaire
    .Columns(5) = "=RC[-2]&RC[-1]"
    .Columns(5) = .Columns(5).Value 'supprime les formules
    lig = 1
    For i = 2 To .Rows.Count
        crit = .Cells(i, 3) & .Cells(i, 4)
        If .Cells(i, 3) <> "" And Not d.exists(crit) Then
            d(crit) = ""
            .AutoFilter 5, crit 'filtre automatique
            .Copy .Cells(lig, 10) 'copier-coller
            .AutoFilter 'ôte le filtre
            .Cells(lig, 10).Resize(, 7).Clear 'supprime les titres
            .Cells(lig + 1, 10).CurrentRegion.Resize(, 7).Offset(3).Clear 'ne garde que 3 lignes
            .Cells(lig + 1, 9) = 1
            If .Cells(lig + 2, 10) <> "" Then .Cells(lig + 2, 9) = 2
            If .Cells(lig + 3, 10) <> "" Then .Cells(lig + 3, 9) = 3
            h = Application.Max(.Cells(lig + 1, 9).Resize(3))
            .Cells(lig + 1, 17) = "=SUM(RC[-1]:R[" & h - 1 & "]C[-1])"
            lig = lig + h + 1
        End If
    Next
    .Columns(14).Delete xlToLeft
    .Columns(5).Delete xlToLeft 'supprime la colonne auxiliaire
End With
End Sub
A+
Cliquez pour agrandir...
Parfait merci encore
il y a une chose que j'ai oublé de vous dire c'est qu'il faut 3 tireurs pour faire une équipe
ça se complique !!!!!!!! car il faut que les tireurs soit du meme club et de la meme catégorie
je joint un exemple (c'st vrai j'ai manqué de précision)
Camille
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour LE BLEVEC, le forum,

LE BLEVEC à dit:
il faut que les tireurs soit du meme club et de la meme catégorie
Cliquez pour agrandir...

LE BLEVEC à dit:
si le fitrage n'en donne que se soit 1 ou 2 il n'y a pas d'équipe il en faut 3
Cliquez pour agrandir...

OK donc on ne garde que les filtrages d'au moins 3 éléments :
VB: 
Sub Classer()
Dim d As Object, lig&, i&, crit$
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
[H:O].Clear 'RAZ
With [A1].CurrentRegion
    .Columns(6).NumberFormat = "0.0"
    .Columns(6).Replace ".", ".", xlPart 'convertit la colonne
    .Sort .Columns(3), xlDescending, .Columns(4), , xlAscending, .Columns(6), xlDescending, Header:=xlYes 'tri sur 3 colonnes
    .Columns(6).Insert xlToRight 'colonne auxiliaire
    .Columns(6) = "=RC[-3]&RC[-2]&RC[-1]"
    .Columns(6) = .Columns(6).Value 'supprime les formules
    lig = 1
    For i = 2 To .Rows.Count
        crit = .Cells(i, 3) & .Cells(i, 4) & .Cells(i, 5)
        If .Cells(i, 3) <> "" And Not d.exists(crit) Then
            d(crit) = ""
            .AutoFilter 6, crit 'filtre automatique
            If Application.CountA(.Columns(3).SpecialCells(xlCellTypeVisible)) > 3 Then
                .Copy .Cells(lig, 10) 'copier-coller
                .Cells(lig, 10).Resize(, 7).Clear 'supprime les titres
                .Cells(lig + 1, 10).CurrentRegion.Resize(, 7).Offset(3).Clear 'ne garde que 3 lignes
                .Cells(lig + 1, 9) = 1
                .Cells(lig + 2, 9) = 2
                .Cells(lig + 3, 9) = 3
                .Cells(lig + 1, 17) = "=SUM(RC[-1]:R[2]C[-1])"
                lig = lig + 4
            End If
            .AutoFilter 'ôte le filtre
        End If
    Next
    .Columns(15).Delete xlToLeft
    .Columns(6).Delete xlToLeft 'supprime la colonne auxiliaire
End With
End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

C
  • Résolu(e)
Microsoft 365 tableau de resultat competition
Réponses
8
Affichages
275
CBAUCHET
C
G
  • Résolu(e)
Microsoft 365 Problème de classement final
Réponses
9
Affichages
194
globule
G
S
  • Question Question
XL 2013 Classement automatique score par points et ensuite goal average
2
Réponses
21
Affichages
510
TooFatBoy
TooFatBoy
F
  • Question Question
Autres Concours pétanque sur 3 tours
Réponses
14
Affichages
469
FMI64
F
S
  • Question Question
XL 2016 classement avec conservation des doublons et éviter les sauts des chiffres.
Réponses
10
Affichages
450
saberamira
S
Poulet13
  • Question Question
XL 2021 EXTRAIRE + SOMME des 6 meilleures valeurs avec condition par participant
Réponses
11
Affichages
347
Poulet13
Poulet13
M
  • Résolu(e)
Microsoft 365 utiliser la fonction INDEX + EQUIV avec 2 possibilités
Réponses
2
Affichages
243
Mat65000
M
I
  • Question Question
XL pour MAC Xlsm - Fichier permettant de gérer un cross d'établissement scolaire
Réponses
8
Affichages
568
iruri
I
C
  • Résolu(e)
XL 2016 Automatisation de l'alimentation des cellules de plusieurs feuilles Excel (Formules : Recherchev...)
Réponses
10
Affichages
318
micheldu52
micheldu52
A
  • Question Question
XL 2010 Problème ou alternative à SOMPRODUCT en VBA
Réponses
14
Affichages
552
bruno lemaire
B
N
  • Question Question
Microsoft 365 Gérer les doublons de la fonction "RANG"
2
Réponses
15
Affichages
1 K
mapomme
mapomme
Z
  • Résolu(e)
Microsoft 365 (résolu) Etablir un classement avec des ex-aequo sur la base d'une autre valeur
Réponses
2
Affichages
420
zedude
Z
A
  • Résolu(e)
XL 2019 Macro Excel recherche par occurrence Macro déjà créer juste modifications
2
Réponses
25
Affichages
597
Aeroberto0099bis
A
D
  • Question Question
XL 2016 Classement BLIND Test 30 équipes
Réponses
5
Affichages
684
Modeste geedee
Modeste geedee
M
  • Résolu(e)
XL 2010 Ressortir uniquement les nombres de la musique d'une course hippique
Réponses
5
Affichages
245
mamarus1
M
F
  • Question Question
XL 2016 travail sur tableau
2 3 4
Réponses
55
Affichages
1 K
finarobert
F
N
  • Résolu(e)
XL 2021 Classement d'équipe
Réponses
4
Affichages
1 K
NonoGeek
N
M
  • Question Question
XL 2019 Réaliser un classement automatique pour un tournoi enfants à Mario Kart
Réponses
2
Affichages
966
michel8032
M
Agecanonix35400
  • Question Question
XL 2016 *** RESOLU MERCI :)*** Impression personnalisée.
2 3
Réponses
35
Affichages
486
TooFatBoy
TooFatBoy
T
  • Question Question
XL 2019 mini championnat
Réponses
2
Affichages
632
tigre5
T
Retour