XL 2019 Classement par critere

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

  • export_complet_tir_competition_505_28122024.xlsx
    32 KB · Affichages: 18
Trier par date Trier par votes
A

alexga78

XLDnaute Occasionnel
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
L

LE BLEVEC

XLDnaute Junior
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

  • Excel downloads 2.xlsm
    46.1 KB · Affichages: 2
  • Excel downloads 2.xlsm
    46.1 KB · Affichages: 2
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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

  • Excel downloads 2.xlsm
    36.3 KB · Affichages: 2
Dernière édition:
Vote positif 0 Vote négatif
L

LE BLEVEC

XLDnaute Junior
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

  • PALM-EQUI.pdf
    384.6 KB · Affichages: 5
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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

  • Excel downloads 2.xlsm
    37.4 KB · Affichages: 3
Vote positif 0 Vote négatif

Discussions similaires

S
  • Question
XL 2016 classement avec conservation des doublons et éviter les sauts des chiffres.
Réponses
10
Affichages
367
saberamira
S
R
  • Question
Microsoft 365 Fichier organisation volley-ball
Réponses
1
Affichages
273
halecs93
halecs93
Y
  • Résolu(e)
XL 2016 Tester plusieurs conditions dans plusieurs colonnes différentes
2
Réponses
18
Affichages
974
Gégé-45550
Gégé-45550
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
292
zedude
Z
N
  • Question
Microsoft 365 Gérer les doublons de la fonction "RANG"
2
Réponses
15
Affichages
620
mapomme
mapomme
D
  • Question
XL 2016 Classement BLIND Test 30 équipes
Réponses
5
Affichages
558
Modeste geedee
Modeste geedee
N
  • Résolu(e)
XL 2021 Classement d'équipe
Réponses
4
Affichages
737
NonoGeek
N
cathodique
  • Question
XL 2010 Code de l'IA à corriger
2 3
Réponses
33
Affichages
2 K
cathodique
cathodique
T
  • Question
XL 2019 mini championnat
Réponses
2
Affichages
494
tigre5
T
B
  • Question
Microsoft 365 Problème fonction NB.SI.ENS
Réponses
5
Affichages
319
Staple1600
Staple1600
C
  • Résolu(e)
XL 2019 trouver le rang avec une seule condition
Réponses
3
Affichages
401
carlos
C
M
  • Question
XL 2019 Réaliser un classement automatique pour un tournoi enfants à Mario Kart
Réponses
2
Affichages
797
michel8032
M
G
  • Résolu(e)
XL 2021 Tournoi 16 équipes en 2 poules de 8
2
Réponses
16
Affichages
1 K
gouge
G
G
  • Question
XL 2021 separation d’ex-æquo
Réponses
8
Affichages
431
gigi71960
G
Y
  • Question
XL 2016 Tournoi 12 équipes 2 poules de 6
Réponses
1
Affichages
2 K
Volvo64400
Volvo64400
D
  • Question
Microsoft 365 Cas réel - avec problème complexe sur de la prevision de match en evitant les doublons
Réponses
1
Affichages
691
Dock91
D
R
  • Question
Microsoft 365 Classement avec valeurs identiques
Réponses
3
Affichages
694
Cousinhub
Cousinhub
M
  • Question
XL 2021 Problème d'une formule qui ne fonctionne pas
2
Réponses
21
Affichages
1 K
marco22
M
T
  • Question
Microsoft 365 tournoi pétanque en sextet 6 tours
Réponses
11
Affichages
503
AtTheOne
AtTheOne
M
  • Question
XL 2021 Copier une cellule sur deux et coller dans une autre colonne
Réponses
5
Affichages
431
DJunqueira
D

Membres actuellement en ligne

12 membres et 127 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 261
Messages
2 117 857
Membres
113 354
dernier inscrit
caillet