Changer la police simple mais je n'arrive pas à faire

Voilà,

Pourtant un truc simple, mais difficile pour un débutant

En fait le code semble ok, ou peut-être juste modifier un truc.

Ce que je cherche à faire, c'est changer la couleur de la police dans une zone texte, selon la valeur d'une autre cellule sur une autre feuille.

La zone texte se trouve sur la feuille "source" et le chiffre sur la feuille chiffre.

Le code semble ok

Quel est mon souci

C'est que pour que la macro s’exécute, il faut que je fasse exécuter la macro.

Ensuite, il semblerait que la macro select la zone texte, ce qui fait pas trop discret.

Donc, voici mon code qui se trouve sur une feuille dans la partie VBA dans un module

Sub Changercouleur()

'
' Changercouleur Macro

Dim cellule
cellule = Sheets("chiffre").Range("E6")

If cellule < 1 Then

    ActiveSheet.Shapes.Range(Array("TextBox 1")).Select

    With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorAccent2
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With

Else

    ActiveSheet.Shapes.Range(Array("TextBox 1")).Select

    With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0.150000006
        .Transparency = 0
        .Solid

    End With
  End If

Et voici le fichier tout simple de la macro qui permet de tester

https://www.cjoint.com/c/ELlei5GQ7BA

Merci

Bonjour et bienvenu(e)

Code à coller dans le module de la feuille "Source" (clic droit sur l'onglet de la feuille --> Visualiser le code)

Private Sub Worksheet_Activate()
  Changercouleur
End Sub

Dans le module standard remplace la macro existante par celle-ci

Sub Changercouleur()
' Changercouleur Macro
Dim cellule

  cellule = Sheets("chiffre").Range("E6")

  With ActiveSheet.Shapes.Range(Array("TextBox 1"))
    If cellule > 1 Then
      With .TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorAccent2
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
      End With
    Else
      With .TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0.150000006
        .Transparency = 0
        .Solid
      End With
    End If
  End With
End Sub

Bonjour,

Merci le code marche, j'ai juste inverser le signe < par > car cela faisait l'effet inverse, mais c'est vraiment ce que je recherchais.

Une toute petite question

comme j'ai une deuxième chiffre sur une autre zone texte de la feuille qui doit réponde aux mêmes conditions que mon premier chiffre.

Ce que je veux dire c'est que j'ai deux chiffres dans deux zone texte qui seront placé à deux endroits différents de la feuille, mais qui sont les même.

On peut rajouter le deuxième qui serait

 With ActiveSheet.Shapes.Range(Array("TextBox 2"))

Comme cela ? ou il faut un faire un et

 With ActiveSheet.Shapes.Range(Array("TextBox 2")) and  With ActiveSheet.Shapes.Range(Array("TextBox 2"))

ou

Sub Changercouleur()
' Changercouleur Macro
Dim cellule

  cellule = Sheets("chiffre").Range("E6")

  With ActiveSheet.Shapes.Range(Array("TextBox 1"))
  With ActiveSheet.Shapes.Range(Array("TextBox 2"))

  If cellule < 1 Then
      With .TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorAccent2
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
      End With
    Else
      With .TextFrame2.TextRange.Font.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0.150000006
        .Transparency = 0
        .Solid
      End With
    End If
  End With
End Sub

En tout cas merci bien

Bonjour

Dans ton fichier

amorapa a écrit :

Si ma valeur de la cellule E6 de la feuille chiffre est supérieur à 1 (puisque ce sont des pourcentages)

Alors mettre la valeur dans la zone teste en rouge (le rouge du format ci-dessous inscrit dans le code)

A tester

Sub Changercouleur()
' Changercouleur Macro
Dim cellule

  cellule = Sheets("chiffre").Range("E6")

  With ActiveSheet.Shapes.Range(Array("TextBox 1", "TextBox 2"))
    'With ActiveSheet.Shapes.Range(Array("TextBox 2"))

      If cellule < 1 Then
        With .TextFrame2.TextRange.Font.Fill
          .Visible = msoTrue
          .ForeColor.ObjectThemeColor = msoThemeColorAccent2
          .ForeColor.TintAndShade = 0
          .ForeColor.Brightness = 0
          .Transparency = 0
          .Solid
        End With
      Else
        With .TextFrame2.TextRange.Font.Fill
          .Visible = msoTrue
          .ForeColor.ObjectThemeColor = msoThemeColorText1
          .ForeColor.TintAndShade = 0
          .ForeColor.Brightness = 0.150000006
          .Transparency = 0
          .Solid
        End With
      End If
    End With
  End Sub

MERCI

Je viens de tester, et c'est parfait, ça marche super bien

Les deux zones textes changent de couleur selon le pourcentage. (rouge en dessous de 100) et noir au dessus

Merci beaucoup