XL 2021 Top 10 valeurs avec mois et année

[Deniro01]

Bonsoir à tous et bonne année 2024,
Peut-on avoir le mois et l'année, relatif à une certaine valeur, dans la même cellule d'un tableau. (tableau ci-joint et résultats dans le Top 10)
Merci beaucoup à ceux qui voudront bien répondre.

 

[job75]

Bonsoir Deniro01,

Voici une solution malheureusement bien lourde avec ces 2 fonctions VBA TopMax et TopMin :

Function TopMax(Valeurs As Range, Mois As Range, An As Range, ordre&)
Dim a, b, c, cel As Range, n&, resu(1 To 2, 1 To 1)
ReDim a(Application.Count(Valeurs) - 1) 'base 0
ReDim b(UBound(a))
ReDim c(UBound(a))
For Each cel In Valeurs
    If IsNumeric(CStr(cel)) Then
        a(n) = cel
        b(n) = Mois(cel.Column - Mois.Column + 1)
        c(n) = An(cel.Row - An.Row + 1)
        n = n + 1
    End If
Next
tri_decroissant a, b, c, 0, UBound(a)
If ordre > n Then resu(1, 1) = "" Else resu(1, 1) = a(ordre - 1)
If ordre > n Then resu(2, 1) = "" Else resu(2, 1) = b(ordre - 1) & " " & c(ordre - 1)
TopMax = resu 'vecteur colonne
End Function

Function TopMin(Valeurs As Range, Mois As Range, An As Range, ordre&)
Dim a, b, c, cel As Range, n&, resu(1 To 2, 1 To 1)
ReDim a(Application.Count(Valeurs) - 1) 'base 0
ReDim b(UBound(a))
ReDim c(UBound(a))
For Each cel In Valeurs
    If IsNumeric(CStr(cel)) Then
        a(n) = cel
        b(n) = Mois(cel.Column - Mois.Column + 1)
        c(n) = An(cel.Row - An.Row + 1)
        n = n + 1
    End If
Next
tri_croissant a, b, c, 0, UBound(a)
If ordre > n Then resu(1, 1) = "" Else resu(1, 1) = a(ordre - 1)
If ordre > n Then resu(2, 1) = "" Else resu(2, 1) = b(ordre - 1) & " " & c(ordre - 1)
TopMin = resu 'vecteur colonne
End Function

Sub tri_decroissant(a, b, c, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) > ref: g = g + 1: Loop
    Do While ref > a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      temp = c(g): c(g) = c(d): c(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri_decroissant(a, b, c, g, droi)
If gauc < d Then Call tri_decroissant(a, b, c, gauc, d)
End Sub

Sub tri_croissant(a, b, c, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      temp = c(g): c(g) = c(d): c(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri_croissant(a, b, c, g, droi)
If gauc < d Then Call tri_croissant(a, b, c, gauc, d)
End Sub

Les fonctions renvoient des matrices qui nécessitent une validation matricielle (sauf sur les versions récentes) comme indiqué sur le fichier.

La macro de tri Quick sort a été adaptée pour trier 3 vecteurs.

A+

 

[Deniro01]

Bonsoir Job75
Ça marche très bien. Vous êtes super.
Je pense ajouter quelques lignes au tableau des consommations. ce qui fera l'affaire.
Tous mes remerciements et chapeau bas.
A+

 

[job75]

Une version un peu différente qui trie 2 vecteurs au lieu de 3 :

Function TopMax(Valeurs As Range, Mois As Range, An As Range, ordre&)
Dim a, b, cel As Range, n&, resu(1 To 2, 1 To 1)
ReDim a(Application.Count(Valeurs) - 1) 'base 0
ReDim b(UBound(a))
For Each cel In Valeurs
    If IsNumeric(CStr(cel)) Then
        a(n) = cel
        b(n) = Mois(cel.Column - Mois.Column + 1) & " " & An(cel.Row - An.Row + 1)
        n = n + 1
    End If
Next
tri_decroissant a, b, 0, n - 1
If ordre > n Then resu(1, 1) = "" Else resu(1, 1) = a(ordre - 1)
If ordre > n Then resu(2, 1) = "" Else resu(2, 1) = b(ordre - 1)
TopMax = resu 'vecteur colonne
End Function

Function TopMin(Valeurs As Range, Mois As Range, An As Range, ordre&)
Dim a, b, cel As Range, n&, resu(1 To 2, 1 To 1)
ReDim a(Application.Count(Valeurs) - 1) 'base 0
ReDim b(UBound(a))
For Each cel In Valeurs
    If IsNumeric(CStr(cel)) Then
        a(n) = cel
        b(n) = Mois(cel.Column - Mois.Column + 1) & " " & An(cel.Row - An.Row + 1)
        n = n + 1
    End If
Next
tri_croissant a, b, 0, n - 1
If ordre > n Then resu(1, 1) = "" Else resu(1, 1) = a(ordre - 1)
If ordre > n Then resu(2, 1) = "" Else resu(2, 1) = b(ordre - 1)
TopMin = resu 'vecteur colonne
End Function

Sub tri_decroissant(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) > ref: g = g + 1: Loop
    Do While ref > a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri_decroissant(a, b, g, droi)
If gauc < d Then Call tri_decroissant(a, b, gauc, d)
End Sub

Sub tri_croissant(a, b, gauc, droi) ' Quick sort
Dim ref, g, d, temp
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
    If g <= d Then
      temp = a(g): a(g) = a(d): a(d) = temp
      temp = b(g): b(g) = b(d): b(d) = temp
      g = g + 1: d = d - 1
    End If
Loop While g <= d
If g < droi Then Call tri_croissant(a, b, g, droi)
If gauc < d Then Call tri_croissant(a, b, gauc, d)
End Sub

Bonne nuit.

 

[Deniro01]

Bonjour Job75
Je me suis servi du 1er fichier VBA en l'alignant sur mon classeur. Tout marche à merveille. Très content!
J'essayerai avec l'autre version pour voir.
Tous mes remerciements pour l'aide apportée. C'est le Top!!!
A+

 

[job75]

Bonsoir Deniro01, le forum,

Une solution plus simple qui utilise 4 colonnes auxiliaires pour le tri.

La macro dans le code de la feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Valeurs As Range, Mois As Range, An As Range, a, cel As Range, n&
Set Valeurs = [C5:N11] 'à adapter
Set Mois = Valeurs.Rows(0).Cells
Set An = Valeurs.Columns(0).Cells
ReDim a(1 To Application.Count(Valeurs), 1 To 2) 'base 1
For Each cel In Valeurs
    If IsNumeric(CStr(cel)) Then
        n = n + 1
        a(n, 1) = cel
        a(n, 2) = Mois(cel.Column - Mois.Column + 1) & " " & An(cel.Row - An.Row + 1)
    End If
Next
'---restitution dans les colonnes auxiliaires---
Application.ScreenUpdating = False
Application.EnableEvents = False
[Q:U].ClearContents 'RAZ
If n = 0 Then Exit Sub
[Q1].Resize(n, 2) = a
[Q1].Resize(n, 2).Sort [Q1], xlDescending, Header:=xlNo 'tri décroissant
[T1].Resize(n, 2) = a
[T1].Resize(n, 2).Sort [T1], xlAscending, Header:=xlNo 'tri croissant
Application.EnableEvents = True
End Sub

Elle se déclenche quand on modifie ou valide une cellule quelconque.

Cette solution est aussi plus rapide : la durée d'exécution d'une modification d'une cellule du tableau source est de 4 millisecondes alors qu'elle est de 18 millisecondes avec le fichier (1) du post #4.

A+

 

[Deniro01]

Bonjour Job75 et merci beaucoup.
Bonne solution en effet.
A voir dans mon fichier conso.
A+