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

[Magic_Doctor]

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.

 

[job75]

Bonsoir Magic_Doctor,

Sauf erreur Excel ne permet pas de colorer une partie du format.

A+

 

[Magic_Doctor]

Bonsoir job,

Je le subodorais. Dommage... Ç'aurait été joli...

Buenas noches

 

[job75]

Bonjour Magic_Doctor, le forum,

Alors pour faire joli :

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.

 

[job75]

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 :

MsgBox Evaluate(Replace([B8], ",", ".")) 'pour tester

A+

 

[job75]

Bonjour Magic_Doctor, le forum,

Si l'on veut paramétrer le nombre de décimales :

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.

 

[job75]

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 :

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+

 

[Magic_Doctor]

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+

 

[job75]

Bonsoir Magic_Doctor,

Oui ça ne va pas dans ce cas avec 0 décimale.

Ni avec 1 décimale si l'on entre 15,95

Ni avec 2 décimales si l'on entre 15,195 etc...

Trop compliqué d'essayer d'y remédier.

Bonne nuit.

 

[Magic_Doctor]

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...

 

[job75]

Bonjour Magic_Doctor, le forum,

Trop compliqué d'essayer d'y remédier.

Je pense cependant pouvoir le faire, mais actuellement je n'ai guère le temps.

Bonne journée.

 

[Magic_Doctor]

Bonjour job,

Ce problème qui semblait relativement simple au départ est en fait une véritable gageure. Mais encore merci pour l'intérêt que tu y as accordé.

 

[job75]

Re,

Avec cette routine je pense qu'il n'y a plus de lézard :

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+