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