XL 2010 Précéder un chiffre d'un signe COLORÉ suivant sa valeur

Magic_Doctor

XLDnaute Barbatruc
Bonjour à tous,

Avec l'aide du forum j'avais réussi à obtenir une fonction qui permet d'automatiser des mises en forme.
Suivant le paramétrage de la fonction (voir celle-ci dans la PJ), par exemple :
on rentre 12 --> 12 mL
on rentre 12,5 --> 12,5 mL
on rentre 12,758133 --> 12,76 mL

J'ai par la suite complété cette fonction de telle sorte que (avec cette fois-ci un autre paramétrage) :
on rentre 12 --> + 12 %
on rentre 12,5 --> + 12,5 %
on rentre -12,758133 --> - 12,76 %

Je me demadais s'il serait possible d'affecter dans cette dernière mise en forme une couleur particulière aux "préfixes" "+" ou "-". Par exemple si "+", le "+" est rouge | si "-", le "-" est vert.

Vos avis m'intéressent.
 

Pièces jointes

  • Signe en Couleur.xlsm
    19.3 KB · Affichages: 42

job75

XLDnaute Barbatruc
Bonjour Magic_Doctor, le forum,

Alors pour faire joli :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim f$
With [B8]
  If Not Intersect(Target, .Cells) Is Nothing Then
    Application.EnableEvents = False
    .NumberFormat = "@" 'format Texte
    .Font.ColorIndex = xlAutomatic 'RAZ
    .Value = Replace(.Value, "%", "")
    If IsNumeric(.Value) Then
      f = "0.00"
      If 10 * .Value = Int(10 * .Value) Then f = "0.0"
      If --.Value = Int(.Value) Then f = "0"
      Select Case .Value
        Case Is = 0: .Value = "0 %"
        Case Is > 0
          .Value = "+ " & Format(.Value, f) & " %"
          .Characters(1, 1).Font.Color = vbRed
        Case Is < 0
          .Value = "- " & Format(Abs(.Value), f) & " %"
          .Characters(1, 1).Font.Color = vbGreen
      End Select
    End If
    .Select
    Application.EnableEvents = True
  End If
End With
End Sub
La couleur verte du signe "-" n'est pas très contrastée...

Bonne journée.
 
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Bien entendu la cellule B8 contient du texte.

Pour le convertir en nombre il suffit dans la feuille de calcul d'utiliser --B8

Et en VBA, par exemple :
Code:
MsgBox Evaluate(Replace([B8], ",", ".")) 'pour tester
A+
 

job75

XLDnaute Barbatruc
Bonjour Magic_Doctor, le forum,

Si l'on veut paramétrer le nombre de décimales :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Decim As Range, f$, n
Set Decim = [D8] 'paramétrage du nombre de décimales
With [B8]
  If Not Intersect(Target, Union(.Cells, Decim)) Is Nothing Then
    Application.EnableEvents = False
    On Error Resume Next 'si nombre trop grand
    Decim = Int(Abs(Val(Decim))) 'sécurité
    .NumberFormat = "@" 'format Texte
    .Font.ColorIndex = xlAutomatic 'RAZ
    .Value = Replace(.Value, "%", "")
    If IsNumeric(.Value) Then
      f = "0" & IIf(Decim, "." & String(Decim, "0"), "")
      For n = Decim - 1 To 1 Step -1
        If .Value * 10 ^ n = Int(.Value * 10 ^ n) Then f = "0." & String(n, "0")
      Next
      If --.Value = Int(.Value) Then f = "0"
      Select Case .Value
        Case Is = 0: .Value = "0 %"
        Case Is > 0
          .Value = "+ " & Format(.Value, f) & " %"
          .Characters(1, 1).Font.Color = vbRed
        Case Is < 0
          .Value = "- " & Format(Abs(.Value), f) & " %"
          .Characters(1, 1).Font.Color = vbGreen
      End Select
    End If
    .Select
    Application.EnableEvents = True
  End If
End With
End Sub
Fichier joint.

Bonne journée.
 

Pièces jointes

  • Signe en Couleur(1).xlsm
    25.9 KB · Affichages: 33
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Je sais que tu aimes bien aller au fond des choses.

Ceci devrait te plaire, la longueur du texte et le nombre de décimales peuvent être quelconques :
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Decim As Range, t$, n%, p%
Set Decim = [D8] 'paramétrage du nombre de décimales
With [B8]
  If Not Intersect(Target, Union(.Cells, Decim)) Is Nothing Then
    Application.EnableEvents = False
    On Error Resume Next
    Decim = Int(Abs(Val(Decim))) 'sécurité
    .NumberFormat = "@" 'format Texte
    .Font.ColorIndex = xlAutomatic 'RAZ
    .Value = Replace(.Value, "%", "")
    If IsNumeric(.Value) Then
      '---traitement de texte---
      t = Trim(Replace(Replace(.Value, "+", ""), "-", ""))
      n = 1
      While Mid(t, n, 1) = "0": n = n + 1: Wend '0 non significatifs
      t = Mid(t, n)
      n = InStr(t, Mid(0.1, 2, 1)) 'position du séparateur décimal
      If n = 1 Then t = 0 & t: n = 2
      If n Then
        For p = Application.Min(n + Decim, Len(t)) To n + 1 Step -1
          If Mid(t, p, 1) > "0" Or Mid(t, p + 1, 1) > "4" Then Exit For
        Next
        If Mid(t, p + 1, 1) > "4" Then _
          t = Left(t, p - 1) & Val(Mid(t, p, 1)) + 1 _
            Else t = Left(t, p + (p = n))
      End If
      '---restitution---
      If t = "0" Or t = "" Then
        .Value = "0 %"
      ElseIf Left(.Value, 1) = "-" Then
        .Value = "- " & t & " %"
        .Characters(1, 1).Font.Color = vbGreen
      Else
        .Value = "+ " & t & " %"
        .Characters(1, 1).Font.Color = vbRed
      End If
    End If
    .Select
    Application.EnableEvents = True
  End If
End With
End Sub
Fichier (2).

A+
 

Pièces jointes

  • Signe en Couleur(2).xlsm
    27.6 KB · Affichages: 39
Dernière édition:

Magic_Doctor

XLDnaute Barbatruc
Bonsoir job, le forum,

Pas pu répondre avant, car là où j'étais... pas d'internet...

Chapeau bas pour avoir pu "défier" ainsi Excel. Faut dire que ça en jette !
J'ai fait quelques essais, mais curieusement il y a un problème quand le nombre de décimales = 0 et que l'on rentre, par exemple, 15,5. De 15 à 15,4 --> + 15 % ; en revanche, de 15,5 à 15,9 --> + 151 %
Ce problème semble se présenter uniquement pour un nombre de décimales = 0.

En tout cas merci.

A+
 
Dernière édition:

Magic_Doctor

XLDnaute Barbatruc
J'avais un jour lu une biographie sur Werner Eisenberg. L'un des grands esprits du XXème siècle. L'un des pères de la physique quantique (cf. fameux principe d'incertitude qui porte son nom). Le seul, probablement, qui aurait pu aboutir à la fabrication d'une bombe atomique dans l'Allemagne nazie. Il ne le fit pas !
Bien après la seconde guerre mondiale (après moult démélés avec les gentils-vainqueurs paranoïaques...), un étudiant lui exposa un problème. Eisenberg le ragarda fixement et lui répondit laconiquement : "Le ciel est bleu et les oiseaux y volent".
Voilà une jolie phrase lapidaire pour clore un problème, somme toute, non vital.
Voilà un problème que l'armada de Microsoft (rappelons-le, l'une des entreprises les plus puissantes au monde...) devrait résoudre, afin que le vulgum pecus puisse davantage voler dans un monde de couleurs.
Bref, tout ça n'est pas bien grave ; cela ne m'empêchera pas de rêver cette nuit en couleurs...
 
Dernière édition:

job75

XLDnaute Barbatruc
Re,

Avec cette routine je pense qu'il n'y a plus de lézard :
Code:
Sub PlusUn(t$, n%, p%)
Dim x$, zero%
For p = p To 1 Step -1
  x = Mid(t, p, 1)
  If x >= "0" And x < "9" Then t = Left(t, p - 1) & x + 1 & String(zero, "0"): Exit Sub
  If p < n Then zero = zero + 1
Next
t = 1 & String(zero, "0")
End Sub
Pas très compliqué mais quand même pas évident, il fallait être très précis.

Fichier (3).

A+
 

Pièces jointes

  • Signe en Couleur(3).xlsm
    28.5 KB · Affichages: 33

Discussions similaires

Statistiques des forums

Discussions
312 905
Messages
2 093 469
Membres
105 740
dernier inscrit
Mln