XL 2010 MFC sur couleur texte

[poipoi]

Bonjour le forum,
J'espère juste que ma question n'a pas encore été posée car je n'ai pas pu trouver de solutions..
je recherche une MFC dont la couleur du texte varierait en fonction du résultat, cela existe pour le remplissage des cellules avec les échelles 3 couleurs mais je ne sais pas faire de même pour le texte.
Ou alors si ce n'est pas une MFC, 'quelque chose' qui pourrait faire cela!
un grand merci d'avance

 

[Dranreb]

Bonjour.
Il risque à terme d'y avoir un problème parce que trop de formats de cellules différents auront été créés. Dans cette version seules 16 couleurs de textes différentes sont créées pour des niveaux discrets de 0 à 15 de la plage de températures.
Exemple d'invocation de la nouvelle Sub CoulTxtBleuJaunRoug toujours par Sub Worksheet_Change dans le module Feuil1 (Feuil1).

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Rng As Range, Cel As Range, Mini As Double, Maxi As Double
   Set Rng = Me.[A3:A34]
   Mini = WorksheetFunction.Min(Rng)
   Maxi = WorksheetFunction.Max(Rng)
   If Intersect(Rng, Target) Is Nothing Then Exit Sub
   For Each Cel In Rng
      CoulTxtBleuJaunRoug Cel, Mini, Maxi
      Next Cel
   End Sub

 

[poipoi]

Re Dranreb
Oulala... c'est génial
Ton dernier tableau est tip top... il correspond aussi à ce que je cherche! mais ça se complique trop pour moi...
Tes connaissances et ta pratique sont à des années lumières des miennes..
Alors au cas où, voici mon tableau,
la feuille à " traiter" est : Saisie T° et Récap
et les cellules:
K6:K372
L6:L372,
N6:N372,
O6:O372"

Je sais aussi que le but du forum n'est pas de délivrer une réponse toute prête, que chaque membre doit apprendre à résoudre ses problèmes grâce à l'aide des contributeurs, mais la marche est trop haute pour moi.
Aussi je comprendrais aisément que ce tableau reste reste en l'état.
Et encore merci, tout cela montre l'étendue des possibilités de cet outil, et l'incroyable pugnacité de ses adeptes.

 

[Dranreb]

Dans le module Feuil7 (Saisie T° et Récap) :

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Rng As Range, Mini As Double, Maxi As Double, Cel As Range
   Set Rng = Me.[K6:L371,N6:O371]
   If Intersect(Rng, Target) Is Nothing Then Exit Sub
   Mini = WorksheetFunction.Min(Rng)
   Maxi = WorksheetFunction.Max(Rng)
   For Each Cel In Rng
      CoulTxtBleuJaunRoug Cel, Mini, Maxi
      Next Cel
   End Sub

Vous devriez mettre en gras les colonne K,L,N,O pour que les couleur se voient un tout petit peu mieux.
Donnez des noms mnémoniques à vos modules pour vous y retrouver plus facilement.
J'ajoute un test dans la Sub CoulTxtBleuJaunRoug au cas où la cellule spécifiée ne porte pas de valeur numérique :

Option Explicit
Sub CoulTxtBleuJaunRoug(ByVal Cel As Range, ByVal Mini As Double, ByVal Maxi As Double)
   Const NivMax = 15, NbCoulDif = NivMax + 1
   Dim Niv As Long, A As Double
   If VarType(Cel.Value) <> vbDouble Then Cel.Font.Color = &H0: Exit Sub
   If Maxi > Mini Then
      Niv = Int(Borné(0, NbCoulDif * (Cel.Value - Mini) / (Maxi - Mini), NivMax))
      A = IntpoHyp(Niv, 0, 4, NivMax / 2, 1, NivMax, 0)
   Else: A = 1: End If
   With New Couleur: .EAF 218.75, A: Cel.Font.Color = .C: End With
   End Sub
Private Function Borné(ByVal LimInf As Double, ByVal V As Double, ByVal LimSup As Double) As Double
   Borné = (LimInf + Abs(V - LimInf) - Abs(LimSup - V) + LimSup) / 2
   End Function
Function IntpoHyp(ByVal X As Double, ByVal X1 As Double, ByVal Y1 As Double, _
                                     ByVal X2 As Double, ByVal Y2 As Double, _
                                     ByVal X3 As Double, ByVal Y3 As Double) As Double
   Dim dX As Double, dY As Double
   dX = X3 - X1: If dX = 0 Then IntpoHyp = (2 ^ 53 - 1) * 2 ^ 971: Exit Function
   dY = Y3 - Y1: If dY = 0 Then IntpoHyp = Y1: Exit Function
   IntpoHyp = Y1 + dY * F0à1xyInt((X - X1) / dX, (X2 - X1) / dX, (Y2 - Y1) / dY)
   End Function
Function F0à1xyInt(ByVal X As Double, ByVal XInt As Double, ByVal YInt As Double) As Double
   Dim N As Double, D As Double
   N = YInt * (1 - XInt) * X: D = XInt * (1 - YInt) + X * (YInt - XInt)
   If Abs(N) < Abs(D) * 2 ^ 40 Then F0à1xyInt = N / D Else F0à1xyInt = Sgn(N) * 2 ^ 40
   End Function
Function IntpoLin(ByVal X As Double, ByVal X1 As Double, ByVal Y1 As Double, _
                                     ByVal X2 As Double, ByVal Y2 As Double) As Double
   IntpoLin = Y1 + (Y2 - Y1) * (X - X1) / (X2 - X1)
   End Function

 

[poipoi]

Merci beaucoup Dranreb, tout fonctionne à merveille!

Par contre, je ne sais quoi donner en échange, nul en Excel, mais si vous étiez dans le coin, c'est avec plaisir que je vous aurais fait une tarte, ou donné des courgettes du jardin!!! (Oui je sais c'est moins fun que des lignes de codes mais c'est à peu près les seules choses que je maitrise un petit peu!!).

Bonne journée à vous et à l'ensemble du forum!

 

[Dranreb]

Non merci, mais c'est gentil.
J'en profite pour vous signaler que les couleurs ressortent bien mieux si au lieu de mettre la police en gras on la définit "Arial Black", taille 9.