XL 2016 palmarès (top 10) fournisseurs

eastwick à dit:

Pour moi, c'est ok, je mets la discussion en solutionnée, encore merci

Cliquez pour agrandir...

dysorthographie à dit:

Bonjour,
C'est rigolo que tu te considère toujours comme celui qui a résolu la question !

Tu privés d'éventuelles internautes intéressés par cette question de savoir quelle réponse t'a permis de résoudre ton problème.

Regarde la pièce jointe 1220064

Cliquez pour agrandir...

dysorthographie à dit:

Bonjour,
Alors c'est sur le poste de Cousinhub qu'il faut appliquer la solution et pas au tiens.

Je ne cogite pas je constate que c'est à toi que tu affect la solution,.

Vue que tu avais flaguer à résolu avant ma proposition je savais que je n'étais pas concerné.

Cliquez pour agrandir...

dysorthographie à dit:

j'y suis allé de mon petit couplet également

Cliquez pour agrandir...

• La fonction ne ramène que les fournisseurs correspondant au rang demandé.
• Les ex æquo sont affichés dans l'ordre alphanumérique
• L'utilisateur choisi le rang recherché (10, 18, 50 ...) dans une cellule au dessus du tableau structuré "TS_TopX".
• Le nombre de lignes nécessaires pour afficher la liste complète est indiqué au dessus du TS.
• Si le nombre de lignes du TS est trop petit, un message affiche le nombre de lignes à ajouter.
• Trois noms définis :
  • TopX : la cellule contenant le rang demandé (dans le classeur fourni cellule D1)
  • Idx : le N° de ligne dans le TS (où que soit placé le TS "TS_TopX" dans la feuille)
  • Classement : l'appel de la fonction personnalisée (Classmt(TS_Fournisseur;Topx)

Function Classmt(Rg As Range, Rang As Integer) As Variant
     Dim Tablo, i As Long, F As Long, P As Long, Id As Long, DC As Object, a, rés
    
     Tablo = Rg.Value2
    
     Set DC = CreateObject("Scripting.Dictionary")
     For F = 1 To UBound(Tablo, 1)
          DC(Tablo(F, 1)) = DC(Tablo(F, 1)) + Tablo(F, 2)
     Next
    
     Clefs = DC.Keys: Ttx = DC.items
    
     NbF = DC.Count
     ReDim a(1 To NbF, 1 To 3)
     For F = 1 To NbF
          a(F, 1) = Clefs(F - 1)
          a(F, 2) = Ttx(F - 1)
     Next F
    
     'Tri par ordre alphabétique décroissant des noms des fournisseurs
     Call Q_Tri_TxtD(a, 1, UBound(a), UBound(a, 2), 1)
    
     'Ajout d 'une clé de tri tenant compte de l'ordre alphabétique
     Fmax = WorksheetFunction.Max(Ttx)
     F = Log(Fmax) \ Log(10) + 1      'Comptage du nbre de zéros pour format1
     format1 = String(F, "0") & ".00"
     format2 = "_" & String(7, "0")   'Affichage sur 7 chiffres pour format2
     For F = 1 To NbF
          a(F, 3) = Format(a(F, 2), format1) & Format(F, format2)
     Next F
    
     'Tri alphanumérique décroissant suivant la nouvelle clé
     Call Q_Tri_TxtD(a, 1, UBound(a), UBound(a, 2), 3)
    
     'Liste du Top x (x = rang cherché)
     F = 1: P = 1: Id = 1
     Do
          F = F + 1
          If a(F, 2) = a(F - 1, 2) Then
               Id = Id + 1   'Un fournisseur de plus à ce même rang
          Else
               P = P + Id    'Rang suivant
               If P > Rang Then Exit Do
              Id = 1
          End If
     Loop While F < NbF
    
     F = F - 1
    
     'Tableau résultant limité au rang demandé
     ReDim rés(1 To F, 1 To 2)
     For i = 1 To F
          rés(i, 1) = a(i, 1)
          rés(i, 2) = a(i, 2)
     Next i
    
     Classmt = rés
End Function

'Tri alphanumérique décroissant (évite l'utilisation de l'instruction Option Compare Text)
'ordre (A=a) < ( À=à) < (B=b) < (E=e) < (Ê=ê) < (Z=z) < (Ø=ø)
'Si utilisation de cette instruction les tris "numériques" fonctionnent
Sub Q_Tri_TxtD(a, gauc, droi, ub, col) 'Quick sort de  J. Boisgontier adapté
'a  : tableau à trier
'gauc, droi : bornes du tri
'ub : nbre de colonnes
'col : N° de colonne de la clef de tri
     Dim ref, g, d, Temp, i
     ref = a((gauc + droi) \ 2, col)
     g = gauc: d = droi
     Do
          Do While StrComp(a(g, col), ref, vbTextCompare) = 1: g = g + 1: Loop
          Do While StrComp(ref, a(d, col), vbTextCompare) = 1: d = d - 1: Loop
          If g <= d Then
               For i = 1 To ub
                    Temp = a(g, i): a(g, i) = a(d, i): a(d, i) = Temp
               Next
               g = g + 1: d = d - 1
          End If
     Loop While g <= d
     If g < droi Then Call Q_Tri_TxtD(a, g, droi, ub, col)
     If gauc < d Then Call Q_Tri_TxtD(a, gauc, d, ub, col)
End Sub

AtTheOne à dit:

Bonsoir à toutes & à tous, bonsoir @eastwick

Du coup moi aussi.
Ça ressemble beaucoup à la proposition de @job75, avec quelques fioritures pour dire de mettre mon grain de sel (et avec une pensée pour J Boisgontier et son Quick Sort)

• La fonction ne ramène que les fournisseurs correspondant au rang demandé.
• Les ex æquo sont affichés dans l'ordre alphanumérique
• L'utilisateur choisi le rang recherché (10, 18, 50 ...) dans une cellule au dessus du tableau structuré "TS_TopX".
• Le nombre de lignes nécessaires pour afficher la liste complète est indiqué au dessus du TS.
• Si le nombre de lignes du TS est trop petit, un message affiche le nombre de lignes à ajouter.
• Trois noms définis :
  • TopX : la cellule contenant le rang demandé (dans le classeur fourni cellule D1)
  • Idx : le N° de ligne dans le TS (où que soit placé le TS "TS_TopX" dans la feuille)
  • Classement : l'appel de la fonction personnalisée (Classmt(TS_Fournisseur;Topx)

Faire ça ou peigner la girafe ...
Regarde la pièce jointe 1220190

Je n'ai pas vérifié le niveau de performance

Le code de la fonction :

VB:

Function Classmt(Rg As Range, Rang As Integer) As Variant
     Dim Tablo, i As Long, F As Long, P As Long, Id As Long, DC As Object, a, rés
   
     Tablo = Rg.Value2
   
     Set DC = CreateObject("Scripting.Dictionary")
     For F = 1 To UBound(Tablo, 1)
          DC(Tablo(F, 1)) = DC(Tablo(F, 1)) + Tablo(F, 2)
     Next
   
     Clefs = DC.Keys: Ttx = DC.items
   
     NbF = DC.Count
     ReDim a(1 To NbF, 1 To 3)
     For F = 1 To NbF
          a(F, 1) = Clefs(F - 1)
          a(F, 2) = Ttx(F - 1)
     Next F
   
     'Tri par ordre alphabétique décroissant des noms des fournisseurs
     Call Q_Tri_TxtD(a, 1, UBound(a), UBound(a, 2), 1)
   
     'Ajout d 'une clé de tri tenant compte de l'ordre alphabétique
     Fmax = WorksheetFunction.Max(Ttx)
     F = Log(Fmax) \ Log(10) + 1      'Comptage du nbre de zéros pour format1
     format1 = String(F, "0") & ".00"
     format2 = "_" & String(7, "0")   'Affichage sur 7 chiffres pour format2
     For F = 1 To NbF
          a(F, 3) = Format(a(F, 2), format1) & Format(F, format2)
     Next F
   
     'Tri alphanumérique décroissant suivant la nouvelle clé
     Call Q_Tri_TxtD(a, 1, UBound(a), UBound(a, 2), 3)
   
     'Liste du Top x (x = rang cherché)
     F = 1: P = 1: Id = 1
     Do
          F = F + 1
          If a(F, 2) = a(F - 1, 2) Then
               Id = Id + 1   'Un fournisseur de plus à ce même rang
          Else
               P = P + Id    'Rang suivant
               If P > Rang Then Exit Do
              Id = 1
          End If
     Loop While F < NbF
   
     F = F - 1
   
     'Tableau résultant limité au rang demandé
     ReDim rés(1 To F, 1 To 2)
     For i = 1 To F
          rés(i, 1) = a(i, 1)
          rés(i, 2) = a(i, 2)
     Next i
   
     Classmt = rés
End Function

La fonction Tri Alphanumérique inspirée du Quick sort de J Boisgontier :

VB:

'Tri alphanumérique décroissant (évite l'utilisation de l'instruction Option Compare Text)
'ordre (A=a) < ( À=à) < (B=b) < (E=e) < (Ê=ê) < (Z=z) < (Ø=ø)
'Si utilisation de cette instruction les tris "numériques" fonctionnent
Sub Q_Tri_TxtD(a, gauc, droi, ub, col) 'Quick sort de  J. Boisgontier adapté
'a  : tableau à trier
'gauc, droi : bornes du tri
'ub : nbre de colonnes
'col : N° de colonne de la clef de tri
     Dim ref, g, d, Temp, i
     ref = a((gauc + droi) \ 2, col)
     g = gauc: d = droi
     Do
          Do While StrComp(a(g, col), ref, vbTextCompare) = 1: g = g + 1: Loop
          Do While StrComp(ref, a(d, col), vbTextCompare) = 1: d = d - 1: Loop
          If g <= d Then
               For i = 1 To ub
                    Temp = a(g, i): a(g, i) = a(d, i): a(d, i) = Temp
               Next
               g = g + 1: d = d - 1
          End If
     Loop While g <= d
     If g < droi Then Call Q_Tri_TxtD(a, g, droi, ub, col)
     If gauc < d Then Call Q_Tri_TxtD(a, gauc, d, ub, col)
End Sub

Voilà pour mon joujou, amusez vous bien
À bientôt

Cliquez pour agrandir...