XL 2019 Classement par critere

LE BLEVEC · 28 Décembre 2024

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

alexga78 · 31 Décembre 2024

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

LE BLEVEC · 2 Janvier 2025

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+

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+

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

job75 · 2 Janvier 2025

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+

LE BLEVEC · 2 Janvier 2025

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+

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

job75 · 2 Janvier 2025

Je ne vois pas comment il peut y avoir 3 tireurs quand le filtrage n'en donne qu'un ou deux.

Je passe donc la main.

LE BLEVEC · 2 Janvier 2025

je regrette ca fait beaucoup de travail
si le fitrage n'en donne que se soit 1 ou 2 il n'y a pas d'équipe il en faut 3

LE BLEVEC · Vendredi à 08:51

bonjour Job
ne n'est pas grave, ne soit pas frustré tu as deja fait beaucoup
merci
Camille

job75 · Vendredi à 10:31

Bonjour LE BLEVEC, le forum,

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

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

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+

XL 2019 Classement par critere

LE BLEVEC

XLDnaute Junior

Pièces jointes

alexga78

XLDnaute Occasionnel

LE BLEVEC

XLDnaute Junior

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

LE BLEVEC

XLDnaute Junior

Pièces jointes

job75

XLDnaute Barbatruc

LE BLEVEC

XLDnaute Junior

LE BLEVEC

XLDnaute Junior

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires