Microsoft 365 Thermomètre change de couleur selon le total d'une cellule

Taty 1973

XLDnaute Nouveau
Bonjour à tous,

Pour les macros, je suis débutante et j'aurais besoin de votre aide. J'ai vu un vidéo sur YouTube que j'essaye de le reproduire.

J'ai un tableau pour des dépenses et juste à côté, j'ai un graphique style thermomètre et j'aimerais qui change de couleur selon le total des dépenses. Mon problème est que quand le montant arrive à 75%, la couleur bleu ne change pas en rouge. Dans la vidéo, il y a une macro avec des changements dans le code qui est lié. Quand je change les données dans le tableau j'ai un message Erreur de compilation: Else sans If et dans la fenêtre de code "Sub color ( )" est en jaune (color est le nom de ma macro).

Est ce qu'il y aurait une autre façon de faire?

Merci pour votre aide
 

Pièces jointes

  • Capture.PNG
    Capture.PNG
    76.2 KB · Affichages: 44
  • Capture2.PNG
    Capture2.PNG
    6.6 KB · Affichages: 39
  • Capture3.PNG
    Capture3.PNG
    24.7 KB · Affichages: 42
Solution
bonjour
Pourquoi cette ligne est en vert dans la macro ? ( en commentaire)

VB:
If Sheets("Feuil1").Range("F5").Value <= 0,5 Then

De plus pas de virgule mais un point
Code:
If Sheets("Feuil1").Range("F5").Value <= 0.5 Then

JM27

XLDnaute Barbatruc
Bonjour
Et si tu postais ta macro dans son intégralité?
car le problème se trouve ( a priori) au dessus ( il manque un if comme le dit le message) mais il faut se méfier des messages qui ne sont pas toujours corrects

exemple de if :

If machin=0.5 then
' ton action
elseif machin=0.7 then
' ton action1
elseif machin=0.8 then
' ton action2
elseif machin=0.9 then
' ton action3
end if
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
Bonjour
un exemple a 3 couleurs de 0 à 100
comme ça vite fait à l'arrache ;)
  1. bleu tu es large
  2. vert tu es tranquille
  3. rouge complet t'es mort😅
demo.gif


code dans la feuille concernée
la cellule référence c'est F2 des quelle change le thermomètre aussi
tu a donc un dégradé de 3 couleurs et l'effet vide tout en gardant les proportions couleurs
elle se réduisent ou disparaissent selon le niveau
VB:
Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim A: A = [F2]
    If Button = 1 Then
        A = A + 3
        [F2] = Application.Min(A, 100)
        End If
End Sub

Private Sub CommandButton2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim A: A = [F2]
    If Button = 1 Then
        A = A - 3
        [F2] = Application.Max(A, 0.1)
    End If
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$F$2" Then thermo
End Sub



Sub thermo()
    Dim X#, grd1#, grd2#, grd3#, grd4#, C1&
    X = (100 - [F2]) / 100
    C1 = RGB(255, 255, 150)    'couleur de fond
    With ActiveSheet.Shapes(1).Fill
        .ForeColor.RGB = C1
        .OneColorGradient msoGradientHorizontal, 1, 1
        If X > 0.02 Then gd1 = X Else gd1 = 0.02
        If X > 0.1 Then gd2 = X Else gd2 = 0.1
        If X > 0.3 Then gd3 = X Else gd3 = 0.3
        If X > 0.8 Then gd4 = X Else gd4 = 0.8

        .GradientStops.Insert (C1), gd1
        .GradientStops.Insert RGB(255, 0, 0), gd2
        .GradientStops.Insert RGB(0, 255, 0), gd3
        .GradientStops.Insert RGB(0, 0, 255), gd4
        .GradientStops.Insert RGB(0, 0, 255), 0.999
    End With
End Sub
;)
à toi d'adapter le nom de ta feuille , dela cellule de référence, peu être d'autre couleurs et la couleur de fond
 

Taty 1973

XLDnaute Nouveau
Bonjour
Et si tu postais ta macro dans son intégralité?
car le problème se trouve ( a priori) au dessus ( il manque un if comme le dit le message) mais il faut se méfier des messages qui ne sont pas toujours corrects

exemple de if :

If machin=0.5 then
' ton action
elseif machin=0.7 then
' ton action1
elseif machin=0.8 then
' ton action2
elseif machin=0.9 then
' ton action3
end if

Bonjour,
Normalement il y a un ":" entre else et if.
Sans fichier impossible de vous aider +
Vous pouvez également utiliser Select case et case, un peu plus lisible que des if, else if etc
A +
Bonjour
un exemple a 3 couleurs de 0 à 100
comme ça vite fait à l'arrache ;)
  1. bleu tu es large
  2. vert tu es tranquille
  3. rouge complet t'es mort😅
Regarde la pièce jointe 1126837

code dans la feuille concernée
la cellule référence c'est F2 des quelle change le thermomètre aussi
tu a donc un dégradé de 3 couleurs et l'effet vide tout en gardant les proportions couleurs
elle se réduisent ou disparaissent selon le niveau
VB:
Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim A: A = [F2]
    If Button = 1 Then
        A = A + 3
        [F2] = Application.Min(A, 100)
        End If
End Sub

Private Sub CommandButton2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim A: A = [F2]
    If Button = 1 Then
        A = A - 3
        [F2] = Application.Max(A, 0.1)
    End If
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$F$2" Then thermo
End Sub



Sub thermo()
    Dim X#, grd1#, grd2#, grd3#, grd4#, C1&
    X = (100 - [F2]) / 100
    C1 = RGB(255, 255, 150)    'couleur de fond
    With ActiveSheet.Shapes(1).Fill
        .ForeColor.RGB = C1
        .OneColorGradient msoGradientHorizontal, 1, 1
        If X > 0.02 Then gd1 = X Else gd1 = 0.02
        If X > 0.1 Then gd2 = X Else gd2 = 0.1
        If X > 0.3 Then gd3 = X Else gd3 = 0.3
        If X > 0.8 Then gd4 = X Else gd4 = 0.8

        .GradientStops.Insert (C1), gd1
        .GradientStops.Insert RGB(255, 0, 0), gd2
        .GradientStops.Insert RGB(0, 255, 0), gd3
        .GradientStops.Insert RGB(0, 0, 255), gd4
        .GradientStops.Insert RGB(0, 0, 255), 0.999
    End With
End Sub
;)
à toi d'adapter le nom de ta feuille , dela cellule de référence, peu être d'autre couleurs et la couleur de fond

Bonté divine, je ne sais pas quand, mais c'est certain que je vais essayer. Merci
 

Taty 1973

XLDnaute Nouveau
Bonjour
Et si tu postais ta macro dans son intégralité?
car le problème se trouve ( a priori) au dessus ( il manque un if comme le dit le message) mais il faut se méfier des messages qui ne sont pas toujours corrects

exemple de if :

If machin=0.5 then
' ton action
elseif machin=0.7 then
' ton action1
elseif machin=0.8 then
' ton action2
elseif machin=0.9 then
' ton action3
end if
Bonjour et merci pour votre aide. Si ça peut vous aider d'avoir mon fichier pour m'aider, ça me va
 

Pièces jointes

  • Graphique interactif suivre dépenses macro.xlsm
    24.9 KB · Affichages: 15

patricktoulon

XLDnaute Barbatruc
il fonctionne le tien suffisait de debloquer le 1er if et un "." a la place de"," c'est tout
c'est sympa l'effet bouteille comme ca
VB:
Sub color()
'
' color Macro
'

If Sheets("Feuil1").Range("F5").Value <= 0.5 Then
    ActiveSheet.Shapes.Range(Array("Group 5")).Select
    ActiveSheet.ChartObjects("Graphique 3").Activate
    ActiveChart.FullSeriesCollection(2).Select
    Application.CommandBars("Format Object").Visible = False
    With Selection.Format.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 112, 192)
        .Transparency = 0.6399999857
        .Solid
    End With
    Range("B7").Select
 ElseIf Sheets("Feuil1").Range("F5").Value <= 0.7 Then
    ActiveSheet.Shapes.Range(Array("Group 5")).Select
    ActiveSheet.ChartObjects("Graphique 3").Activate
    ActiveChart.FullSeriesCollection(2).Select
    Application.CommandBars("Format Object").Visible = False
    With Selection.Format.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0.6399999857
        .Solid
    End With
    Range("B7").Select
 Else
  ActiveSheet.Shapes.Range(Array("Group 5")).Select
    ActiveSheet.ChartObjects("Graphique 3").Activate
    ActiveChart.FullSeriesCollection(2).Select
    Application.CommandBars("Format Object").Visible = False
    With Selection.Format.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Solid
    End With
    Range("B7").Select
 End If
End Sub
 

Taty 1973

XLDnaute Nouveau
il fonctionne le tien suffisait de debloquer le 1er if et un "." a la place de"," c'est tout
c'est sympa l'effet bouteille comme ca
VB:
Sub color()
'
' color Macro
'

If Sheets("Feuil1").Range("F5").Value <= 0.5 Then
    ActiveSheet.Shapes.Range(Array("Group 5")).Select
    ActiveSheet.ChartObjects("Graphique 3").Activate
    ActiveChart.FullSeriesCollection(2).Select
    Application.CommandBars("Format Object").Visible = False
    With Selection.Format.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 112, 192)
        .Transparency = 0.6399999857
        .Solid
    End With
    Range("B7").Select
 ElseIf Sheets("Feuil1").Range("F5").Value <= 0.7 Then
    ActiveSheet.Shapes.Range(Array("Group 5")).Select
    ActiveSheet.ChartObjects("Graphique 3").Activate
    ActiveChart.FullSeriesCollection(2).Select
    Application.CommandBars("Format Object").Visible = False
    With Selection.Format.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0.6399999857
        .Solid
    End With
    Range("B7").Select
 Else
  ActiveSheet.Shapes.Range(Array("Group 5")).Select
    ActiveSheet.ChartObjects("Graphique 3").Activate
    ActiveChart.FullSeriesCollection(2).Select
    Application.CommandBars("Format Object").Visible = False
    With Selection.Format.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Solid
    End With
    Range("B7").Select
 End If
End Sub
Un gros merci, ça fonctionne.
 

Discussions similaires

Réponses
6
Affichages
266

Statistiques des forums

Discussions
311 720
Messages
2 081 915
Membres
101 837
dernier inscrit
Ugo