Discussion :

[NEC14]

Bonjour à tous,

Voilà j'ai mis en place ce code qui distribue des prix selon un nombre de points acquis par le candidats. Hors, je rencontre un problème que je n'arrive pas à résoudre :

Pour les candidats ayant un résultat compris entre 1 et 30, le prix attribué est le "Prix d'encouragements des Jurats".

Pour les candidats ayant un résultat compris entre 31 et 50, le prix attribué est le "3ème prix d'excellence". Mais seul le candidat ayant le meilleur score reçoit ce prix.

Idem pour les résultats entre 51 et 61.

Avec mon code actuel, tous les candidats reçoivent un prix et ce n'est pas ce que je recherche.

Pourriez-vous m'apporter votre aide s'il vous plait, je planche là-dessus depuis 2 jours sans y parvenir.

Je vous en remercie par avance

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 
Function TitrePrix2(Resultat As Double, ResultatsLaureats As Range) As String
'résultat est la valeur à tester
'ResultatsLaureats est l'ensemble des résultats à évaluer en vue de connaitre le grand gagnant
 
 
'résultat de base pour les c
Select Case Fix(Resultat)
    Case 1 To 30
        TitrePrix2 = "Prix d'encouragements des Jurats"
    Case 31 To 50
        TitrePrix2 = "3ème Prix d'Excellence"
    Case 51 To 61
        TitrePrix2 = "2er Prix d'Excellence"
End Select
'est-ce le meilleur résultat?
'si oui, c'est un gaillard ce lascar!
If Application.WorksheetFunction.Max(ResultatsLaureats) = Resultat And Resultat > 61 Then TitrePrix2 = "1er Prix d'Excellence Saint Honoré"
 
End Function

[aalex_38]

Bonsoir,

Sans voir tout le code ou le fichier difficile à dire.
Enfin tu dois boucler sur toutes les personnes et chaque fois que tu est dans un de tes 3 critères tu l'enregistre et à chaque boucle tu compare au précédent.
A la fin tu auras les 3 plus grands pour chaque palier !


Edit: trop fatigué pour penser ce soir, ...
Il doit y avoir aussi des formules

[NEC14]

Bonsoir aalex_38,

Merci pour ta réponse. Dans un tableau j'entre toute une série de nom de candidats ainsi qu'une série de notes.

J'ai bien compris ta proposition mais je ne sais pas le faire, je ne sais pas écrire le code.

Je pensais m'inspirer de la dernière ligne du code, pour les candidats ayant une note supérieur à 61. Dans ce cas de figure, seul le meilleur de cette catégorie reçoit le prix, mais cela ne marche pour les autres.

Qu'en penses-tu ?

[Theze]

Bonjour,

Teste ce qui suit :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
 
Function TitrePrix2(Resultat As Double, ResultatsLaureats As Range) As String
 
    Dim Cel As Range
    Dim Val30 As Double
    Dim Val50 As Double
    Dim Val61 As Double
    Dim ValMax As Double
 
    Application.Volatile
 
    For Each Cel In ResultatsLaureats
 
        Select Case Cel.Value
 
        Case 1 To 30
 
            If Val30 < Cel.Value Then Val30 = Cel.Value
 
        Case 31 To 50
 
            If Val50 < Cel.Value Then Val50 = Cel.Value
 
        Case 51 To 61
 
            If Val61 < Cel.Value Then Val61 = Cel.Value
 
        End Select
 
    Next Cel
 
    ValMax = Application.WorksheetFunction.Max(ResultatsLaureats)
 
    If Val30 = Resultat Then
 
        TitrePrix2 = "Prix d'encouragements des Jurats"
 
    End If
 
    If Val50 = Resultat Then
 
        TitrePrix2 = "3ème Prix d'Excellence"
 
    End If
 
    If Val61 = Resultat Then
 
        TitrePrix2 = "2er Prix d'Excellence"
 
    End If
 
    If ValMax = Resultat And Resultat > 61 Then
 
        TitrePrix2 = "1er Prix d'Excellence Saint Honoré"
 
    End If
 
End Function

Hervé.

[NEC14]

Bonjour Theze,

Désolé d'avoir tardé à répondre. Petit problème de santé.

Après avoir relu ton code, qui fonctionne, je me suis aperçu que quelque chose ne collais pas et cela est entièrement de ma faute.

En fait, le plus grand nombre de points reçoit le 1er prix "1er Prix Saint Honoré", le 2ème "2ème Prix d'Excellence", le 3 ème "3ème prix d'excellence" et les 9 autres le "Prix d'encouragement des Jurats".

Je travaille pour une association et je n'avais pas eu correctement toutes les informations.

Toutes mes excuses

Je dois donc recommencer ce code, peux-tu m'aider ? ou quelqu'un d'autre

Merci par avance

[aalex_38]

Bonjour,

Un exemple pour trier la deuxième colonne, de la feuil1

Nom Score
Nom26 99
Nom25 96
Nom33 94
Nom46 94
Nom24 93
Nom41 92
Nom35 91
Nom14 89
Nom21 82
Nom39 78
Nom1 76
Nom5 76

Et le code pour trier :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Dim Derlig As Long, RRANGE As Range, Valeur As Long, i As Long
Const Mcol As Integer = 1 ' Colonne des noms
Derlig = Feuil1.Cells(Rows.Count, Mcol).End(xlUp).Row
Set RRANGE = Feuil1.Range(Cells(2, Mcol), Cells(Derlig, Mcol + 1))
If RRANGE Is Nothing Then: Exit Sub
Dim Montab As Variant, cmpt1 As Long, cmpt2 As Long, Cible As String, Nom As String
Montab = RRANGE
 
 
Do 'tri décroissant
        Valeur = 0
        For i = 1 To UBound(Montab, 1) - 1
        i = i
                If Montab(i, 2) < Montab(i + 1, 2) Then
                    Cible = Montab(i, 2):                      Nom = Montab(i, 1)
                    Montab(i, 2) = Montab(i + 1, 2):           Montab(i, 1) = Montab(i + 1, 1)
                    Montab(i + 1, 2) = Cible:                  Montab(i + 1, 1) = Nom
                    Valeur = 1
            End If
         Next i
Loop While Valeur = 1
 
  RRANGE = Montab

Je mets un fichier cet aprem


Edit : un fichier pour le principe, il y a plusieurs façons de faire.

[NEC14]

Bonsoir aalex_38

Merci pour ta réponse, je teste ton code à mon application et je te tiens informé de la suite.

Cordialement

[Theze]

Bonsoir,

Je ne sais pas si j'ai bien compris ce que tu veux ?
- Le plus grand score reçois : "1er Prix Saint Honoré"
- Le second score reçois : "2ème Prix d'Excellence"
- Le troisième score reçois : "3ème prix d'excellence"
- Et les 9 scores suivants reçoivent : "Prix d'encouragements des Jurats"
J'ai mis une ligne en commentaire si les "Prix d'encouragements des Jurats" doivent être numéroté :
Donc, voici ce qui sort de ce que j'ai compris :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
 
Function TitrePrix2(Resultat As Double, ResultatsLaureats As Range) As String
 
    Dim I As Integer
 
    Application.Volatile
 
    'si c'est le plus grand score
    If Resultat = Application.WorksheetFunction.Large(ResultatsLaureats, 1) Then
 
        TitrePrix2 = "1er Prix d'Excellence Saint Honoré"
 
    End If
 
    'si c'est le second score
    If Resultat = Application.WorksheetFunction.Large(ResultatsLaureats, 2) Then
 
        TitrePrix2 = "2ème Prix d'Excellence"
 
    End If
 
    'si c'est le troisième score
    If Resultat = Application.WorksheetFunction.Large(ResultatsLaureats, 3) Then
 
        TitrePrix2 = "3ème prix d'excellence"
 
    End If
 
    'si ce sont les 4 ème aux 12 ème scores
    For I = 4 To 12
 
        If Resultat = Application.WorksheetFunction.Large(ResultatsLaureats, I) Then
 
            TitrePrix2 = "Prix d'encouragements des Jurats"
            'si les titres doivent être numérotés
            'TitrePrix2 = I - 3 & IIf(I = 4, "er", "ème") & " prix d'encouragements des Jurats"
 
 
        End If
 
    Next I
 
End Function

Hervé.

[aalex_38]

Bonjour à tous,


Sympa la fonction Application.WorksheetFunction.Large, moi j'avais pensé à un tri, puis à parcourir les éléments.

Et elle retourne quoi la fonction si plusieurs concurents ont la même note ?

[Theze]

Bonjour,

Et voilà, j'ai répondu trop vite Tu as parfaitement raison aalex_38, je n'ai pas testé plus loin et j'ai posté une bêtise ! Ta proposition fonctionne très bien, Nec14 pourra aisément en faire une fonction.

Hervé.

[CodeFacile]

La fonction large ne emble pas présente en Excel 2003.

J'avais plutôt imaginer l'emploi d'une fonction du type rang ou index

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
If Application.WorksheetFunction.rang(chaine_fonction) = 1  then prix = "  "

[aalex_38]

Bonjour,

Et voilà, j'ai répondu trop vite Tu as parfaitement raison aalex_38, je n'ai pas testé plus loin et j'ai posté une bêtise ! Ta proposition fonctionne très bien, Nec14 pourra aisément en faire une fonction.

Hervé.

En realité, nous n'avons pas toutes les précisions, donc ce n'est pas une bétise.
En plus l'idée de passer par une fonction est plutot interessante pour sa concision.

Bon week.

[Theze]

Re,

N'aimant pas rester sur un échec, j'ai répondu une fonction (un peu usine à gaz tout de même ) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
 
Function TitrePrix2(Resultat As Double, ResultatsLaureats As Range) As String
 
    Dim I As Long
    Dim Min As Long
    Dim Max As Long
    Dim Troisieme As Double
    Dim Quatrieme As Double
 
    Application.Volatile
 
    With Application.WorksheetFunction
 
        'le ou les premiers prix
        If Resultat = .Max(ResultatsLaureats) Then
 
            If .CountIf(ResultatsLaureats, Resultat) > 1 Then
 
                TitrePrix2 = "1er Prix d'Excellence Saint Honoré (ex-equo)"
 
            Else
 
                TitrePrix2 = "1er Prix d'Excellence Saint Honoré"
 
            End If
 
            Exit Function 'inutile d'aller plus loin
 
        End If
 
        'le ou les seconds prix
        If Resultat = .Large(ResultatsLaureats, .CountIf(ResultatsLaureats, .Max(ResultatsLaureats)) + 1) Then
 
            If .CountIf(ResultatsLaureats, Resultat) > 1 Then
 
                TitrePrix2 = "2ème Prix d'Excellence (ex-equo)"
 
            Else
 
                TitrePrix2 = "2ème Prix d'Excellence"
 
            End If
 
            Exit Function 'inutile d'aller plus loin
 
        End If
 
        'le ou les troisièmes prix
        Troisieme = .Large(ResultatsLaureats, .CountIf(ResultatsLaureats, .Max(ResultatsLaureats)) + 1)
 
        If Resultat = .Large(ResultatsLaureats, .CountIf(ResultatsLaureats, .Max(ResultatsLaureats)) + .CountIf(ResultatsLaureats, Troisieme) + 1) Then
 
            If .CountIf(ResultatsLaureats, Resultat) > 1 Then
 
                TitrePrix2 = "3ème prix d'excellence (ex-equo)"
 
            Else
 
                TitrePrix2 = "3ème prix d'excellence"
 
            End If
 
            Exit Function 'inutile d'aller plus loin
 
        End If
 
        'les derniers prix (9 au maximum)
        Quatrieme = .Large(ResultatsLaureats, .CountIf(ResultatsLaureats, .Max(ResultatsLaureats)) + .CountIf(ResultatsLaureats, Troisieme) + 1)
 
        Min = .CountIf(ResultatsLaureats, .Max(ResultatsLaureats)) + .CountIf(ResultatsLaureats, Troisieme) + .CountIf(ResultatsLaureats, Quatrieme)
 
        Max = Min + IIf((ResultatsLaureats.Cells.Count - Min + 1) > 9, 9, ResultatsLaureats.Cells.Count - Min + 1)
 
        For I = Min + 1 To Max
 
            If Resultat = .Large(ResultatsLaureats, I) Then
 
                TitrePrix2 = "Prix d'encouragements des Jurats"
 
            End If
 
        Next I
 
    End With
 
End Function

Hervé.

[NEC14]

Bonjour à tous,

Merci pour vos réponses. J'ai préféré la dernière proposition d'Hervé, bien que les autres soient intéressantes.

Il ne peut pas y avoir de candidats exéquo. Dans ce cas les notes seraient revues de manière qu'il n'y ait qu'un seul vainqueur à chaque niveau - sauf à partir du 4ème.

Cependant je rencontre un problème, pour les 3 premiers prix, aucun soucis. Mais à partir du 4ème prix, le réponse est #VALEUR!

J'ai beau chercher la solution je ne vois où est l'erreur.

Merci pour vos idées.

Amicalement

René

[Theze]

Bonjour,

Et bien, si il ne peut y avoir de note identiques alors le plus simple à mon sens est ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
 
Function TitrePrix2(Resultat As Double, ResultatsLaureats As Range) As String
 
    Dim I As Long
    Dim Troisieme As Double
    Dim Quatrieme As Double
 
    Application.Volatile
 
    With Application.WorksheetFunction
 
        'le premier prix
        If Resultat = .Max(ResultatsLaureats) Then
 
            TitrePrix2 = "1er Prix d'Excellence Saint Honoré"
 
            Exit Function 'inutile d'aller plus loin
 
        End If
 
        'le second prix
        If Resultat = .Large(ResultatsLaureats, 2) Then
 
            TitrePrix2 = "2ème Prix d'Excellence"
 
            Exit Function 'inutile d'aller plus loin
 
        End If
 
        'le troisième prix
        If Resultat = .Large(ResultatsLaureats, 3) Then
 
            TitrePrix2 = "3ème prix d'excellence"
 
            Exit Function 'inutile d'aller plus loin
 
        End If
 
        'les derniers prix (9 au maximum)
        For I = 4 To IIf(ResultatsLaureats.Cells.Count - 3 > 9, 12, ResultatsLaureats.Cells.Count)
 
            If Resultat = Application.WorksheetFunction.Large(ResultatsLaureats, I) Then
 
                'TitrePrix2 = "Prix d'encouragements des Jurats"
                'si les titres doivent être numérotés
                TitrePrix2 = I - 3 & IIf(I = 4, "er", "ème") & " prix d'encouragements des Jurats"
 
 
            End If
 
        Next I
 
    End With
 
End Function

#VALEUR! vient du fait que la plage est inférieure à 12 (1er prix + 2ème prix + 3ème prix plus 9 prix suivants) mais la
Hervé.

[Theze]

Re,

décidément, avec mes gros doigts
Je voulais juste dire que la fonction gère les plages inférieures à 12

Hervé.

[NEC14]

Merci Hervé, mais j'ai toujours la même erreur. Les 3 premiers prix fonctionnent, mais à partir du 4ème #VALEUR! s'affiche toujours.

Voici une partie du fichier

[Theze]

Re,

C'est parce que ta plage est en grande partie vide mais voilà, j'ai rectifié avec CountA afin d'avoir le bon nombre de cellules correspondant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
 
Function TitrePrix2(Resultat As Double, ResultatsLaureats As Range) As String
 
    Dim I As Long
    Dim Troisieme As Double
    Dim Quatrieme As Double
 
    Application.Volatile
 
    With Application.WorksheetFunction
 
        'le premier prix
        If Resultat = .Max(ResultatsLaureats) Then
 
            TitrePrix2 = "1er Prix d'Excellence Saint Honoré"
 
            Exit Function 'inutile d'aller plus loin
 
        End If
 
        'le second prix
        If Resultat = .Large(ResultatsLaureats, 2) Then
 
            TitrePrix2 = "2ème Prix d'Excellence"
 
            Exit Function 'inutile d'aller plus loin
 
        End If
 
        'le troisième prix
        If Resultat = .Large(ResultatsLaureats, 3) Then
 
            TitrePrix2 = "3ème prix d'excellence"
 
            Exit Function 'inutile d'aller plus loin
 
        End If
 
        'les derniers prix (9 au maximum)
        For I = 4 To IIf(.CountA(ResultatsLaureats) - 3 > 9, 12, .CountA(ResultatsLaureats))
 
            If Resultat = Application.WorksheetFunction.Large(ResultatsLaureats, I) Then
 
                'TitrePrix2 = "Prix d'encouragements des Jurats"
                'si les titres doivent être numérotés
                TitrePrix2 = I - 3 & IIf(I = 4, "er", "ème") & " prix d'encouragements des Jurats"
 
 
            End If
 
        Next I
 
    End With
 
End Function

Hervé.

[NEC14]

Super Hervé ça fonctionne très bien. Merci beaucoup pour ton aide ainsi qu'à tous ceux qui ont participé à ce post.

A bientôt et bon week-end