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
job75

job75

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

Pièces jointes

  • export_complet_tir_competition_505_28122024.xlsm
    36.3 KB · Affichages: 10
Vote positif 0 Vote négatif
micheldu52

micheldu52

XLDnaute Occasionnel
LE BLEVEC à dit:
Bonjour Michel
c'est tres sympas et réponse rapide
mais il manque catégorie
Camille
Cliquez pour agrandir...
Oups, petite erreur...

Dans la colonne S, modifie (toutes) les formules
=RECHERCHEV($Q$3*100+$O5;$A:$J;9;FAUX)

par
=RECHERCHEV($Q$3*100+$O5;$A:$J;8;FAUX)

(le 9 est en réalité un 8, la 8 éme colonne par rapport à la A, c'est à dire la H qui est celle qui contient la catégorie alors que le 9 renvoyait à la 9éme colonne c'est à dire la I qui contient le club

Michel
 
Vote positif 0 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...
bonsoir
merci pour le travail de fait impeccable
mais (c'est de ma faute) dans classer ,dans les epreuve categorie il faudrait qu'il n'y a pas de ligne vide
mea coulpa
merci encore
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour le forum,
LE BLEVEC à dit:
mais (c'est de ma faute) dans classer ,dans les epreuve categorie il faudrait qu'il n'y a pas de ligne vide
Cliquez pour agrandir...
Alors utilisez cette macro :
VB: 
Sub Classer()
Dim d As Object, lig&, i&, crit$, n&
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 = 2
    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
            .Offset(1).Copy .Cells(lig, 10) 'copier-coller
            n = .SpecialCells(xlCellTypeVisible).Count / 6
            .AutoFilter 'ôte le filtre
            .Cells(lig, 10).Resize(n, 7).Offset(3).Clear 'ne garde que 3 lignes
            .Cells(lig, 9) = 1
            If .Cells(lig + 1, 10) <> "" Then .Cells(lig + 1, 9) = 2
            If .Cells(lig + 2, 10) <> "" Then .Cells(lig + 2, 9) = 3
            lig = lig + Application.Max(.Cells(lig, 9).Resize(3))
        End If
    Next
    .Columns(14).Delete xlToLeft
    .Columns(5).Delete xlToLeft 'supprime la colonne auxiliaire
    .Rows(1).Copy [I1] 'titres
End With
End Sub
A+
 

Pièces jointes

  • export_complet_tir_competition_505_28122024.xlsm
    36.6 KB · Affichages: 8
Vote positif 0 Vote négatif
L

LE BLEVEC

XLDnaute Junior
désolé quand on connait Power Query c'est formidable et en plus bien présenté, mais moi je ne l'ai jamais utilisé, je connaissais pas
quand tu me dis remplacer tableau, mais moi je veux replacer les colonnes de A à F par d'autre données qui peut etre d'autre nom, epreuve, categorie, points
alors là mystère, mais tu n'es pas obligé de passer ton temps avec moi
merci pour tout
 
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

13 membres et 163 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 260
Messages
2 117 856
Membres
113 354
dernier inscrit
caillet