XL 2010 Colorier les n plus grandes valeurs d'une plage EXCEL

mapomme à dit:

Re,
Un autre version VBA v11 plus rapide et plus simple que la v1.
Une petite nouveauté : la couleur de fond des cellules sera la couleur de fond de la cellule AA1. Quand vous modifiez la couleur de fond de cette cellule, revalidez son contenu (celui de la cellule AA1) pour la prise en compte de la nouvelle couleur.
Le code de la v11 :

VB:

Public Sub NgrandeValeur()                ' colorier les N grandes valeurs de gauche à droite (notez que la Sub est publique)
Dim t, Ncell&, i&, nv&, j&, k&, ech As Boolean, x, n&, couleur
   With Me                                ' avec la feuille courante (Feuil1)
      Application.ScreenUpdating = False  ' on fige l'écran (l'affichage est plus rapide)
      t = .Range("a1").CurrentRegion: Ncell = .Range("aa1")     ' lecture des valeurs du tableau et de N
      couleur = .Range("aa1").Interior.Color                              ' couleur du fond à utiliser
      .Range("b2").Resize(UBound(t) - 1, UBound(t, 2) - 1).Interior.ColorIndex = xlColorIndexNone  ' sans fond de couleur
      ' on déclare un tableau v des valeurs d'une ligne et de leur indice au sein de la ligne
      ReDim v(1 To UBound(t, 2) - 1): ReDim a(1 To UBound(v))
      For i = 2 To UBound(t)                                ' pour chaque ligne du tableau t,on remplit les tableaux v et a
         nv = 0                                             ' nv = nombre de valeurs de la ligne (au départ 0)
         For j = 2 To UBound(t, 2)                          ' pour chaque colonne de la ligne i du tableau t
            If t(i, j) <> "" Then nv = nv + 1: v(nv) = t(i, j): a(nv) = j  ' on stocke la valeur dans v et son index dans a
         Next j
         ' Tri de v et a (du plus grand au plus petit avec un tri à bulle car c'est un tri stable)
         Do                      ' boucle infinie
            ech = False          ' initialisation de l'indicateur d'échange pour un tour (au départ aucun échange)
            For k = 1 To nv - 1  ' depuis le premier élément de v jusqu'au dernier moins 1
               ' si l'élément j est inf. à l'élément j+1, on inverse les éléments j et j-1 de v (et a) et ech est true
               If v(k) < v(k + 1) Then x = v(k): v(k) = v(k + 1): v(k + 1) = x: x = a(k): a(k) = a(k + 1): a(k + 1) = x: ech = True
            Next k
         Loop While ech          ' Tant qu'on a fait au moins un échange on refait un tour - sinon le tri est terminé
         If Ncell > nv Then n = nv Else n = Ncell   ' nbre de cellules à colorier (le max étant nv : nombre de valeurs de la ligne)
         For j = 1 To n: .Cells(i, a(j)).Interior.Color = couleur: Next      ' coloriage
      Next i
   End With
End Sub

Cliquez pour agrandir...

CHRIS1945 à dit:

Bonsoir à tous :
Voici ce que Aurélie dit :

aurelio.ewane à dit:
Lorsque l'on veut les 03 premières plus grandes valeurs, alors ca colorie 100 02 fois mais ca ne compte que une fois et du coup sur cette ligne ca a colorier 04 cellules au lieu de 03 cellules
qui devait etre les cellules contenant
1ere cellule celle qui contient 100
2e cellule celle qui contient 100
3e cellule celle qui contient 150
ca fait en tous 03 plus grandes valeurs

Désolé mais c'est ce que fait ma proposition : on colorie toutes les premières valeurs identiques et les deuxièmes valeurs identiques càd sur la ligne exemple :
La première valeur qui est unique : 150
et la deuxième valeur qui en contient 2 à savoir 2 fois 100

Je ne comprend donc pas la critique sur mo projet.

Merci d'éclaircir ma lanterne
A+
Chris

Cliquez pour agrandir...

AtTheOne à dit:

re

Pour répondre à cette demande restée sans réponse (Attention aux noms dupliqués, j'ai supprimé les doublons)

Cette macro trie les feuilles nommées "Class N°"

• Si pas de N° placée en 1er
• Si autre type de nom en fin

VB:

Sub tri(a, gauc, droi)          ' Quick sort croissant  de J. Boisgontier adapté
     ref = a(2, (gauc + droi) \ 2)
     g = gauc: d = droi
     Do
          Do While a(2, g) < ref: g = g + 1: Loop
          Do While ref < a(2, d): d = d - 1: Loop
          If g <= d Then
               Temp = a(1, g): a(1, g) = a(1, d): a(1, d) = Temp
               Temp = a(2, g): a(2, g) = a(2, d): a(2, d) = Temp
          g = g + 1: d = d - 1
          End If
     Loop While g <= d
     If g < droi Then Call tri(a, g, droi)
     If gauc < d Then Call tri(a, gauc, d)
End Sub


Sub OrdonneSh()
     Dim Tb()
     nb = 0
     For Each Wsh In ThisWorkbook.Worksheets
          If UCase(Wsh.Name) Like "CLASS*" Then
               nb = nb + 1
               ReDim Preserve Tb(1 To 2, 1 To nb)
               part = Split(Wsh.Name, " ")
               Tb(1, nb) = Wsh.Name
               If UBound(part) = 1 Then
                    Tb(2, nb) = CInt(part(1))
               End If
          End If
     Next
     Call tri(Tb, 1, UBound(Tb, 2))
     ThisWorkbook.Worksheets(Tb(1, 1)).Move Before:=ThisWorkbook.Worksheets(1)
     For i = 2 To UBound(Tb, 2)
          ThisWorkbook.Worksheets(Tb(1, i)).Move After:=ThisWorkbook.Worksheets(Tb(1, i - 1))
     Next
     Application.Goto ThisWorkbook.Worksheets(Tb(1, 1)).[A1]

End Sub

en attendant une amélioration de @job75 😄

À bientôt

Cliquez pour agrandir...

CHRIS1945 à dit:

on colorie toutes les premières valeurs identiques et les deuxièmes valeurs identiques

Cliquez pour agrandir...