Colorer le rectangle en rouge VBA

Bonjour,

J'ai besoin d'une Macro qui fait la fonction en dessous ;

1 - Si cette cellule et supérieur a 0, colorer le rectangle en rouge

2 - Si égale a 0 colorer le rectangle en vert

Dans le fichier joint vous aurais plus de détails.

Cdt

Bonjour,

en colonne A on doit toujours avoir un nom de poste de la forme :"POSTEespaceN°" (comme dans le classeur) et sans espace après (pas comme dans le classeur).

Le Nom des forms doit être de la forme : "Rectangle à coins arrondisespaceN°" (comme dans le classeur) .

Une solution qui "réagit" à chaque changement dans la colonne B (à copier dans la feuille de code de la feuille)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim DL As Long, Sh As String
DL = Range("A" & Rows.Count).End(xlUp).Row
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("B2:B" & DL)) Is Nothing Then
    Sh = "Rectangle à coins arrondis" & Right(Target.Offset(, -1), Len(Target.Offset(, -1)) - 5)
    If Target.Value > 0 Then
        ActiveSheet.Shapes(Sh).Fill.ForeColor.SchemeColor = 10
    Else
        ActiveSheet.Shapes(Sh).Fill.ForeColor.SchemeColor = 11
    End If
End If
End Sub

Si la mise à jour se fait par formule, modifier Range("B2:B" & DL) en fonction de la plage modifiée manuellement qui provoquera le changement en colonne B.

Sinon une solution qui balaye les données de la colonne B et met à jour les forms globalement:

Sub macro()
Dim DL As Long, Sh As String,i as long
DL = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To DL
    Sh = "Rectangle à coins arrondis" & Right(Cells(i, 1), Len(Cells(i, 1)) - 5)
    If Cells(i, 2).Value > 0 Then
        ActiveSheet.Shapes(Sh).Fill.ForeColor.SchemeColor = 10
    Else
        ActiveSheet.Shapes(Sh).Fill.ForeColor.SchemeColor = 11
    End If
Next
End Sub

A+

Bonjour,

bonjour Algoplus,

Une autre proposition à étudier.

Cdlt.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, shp As ShapeRange, lColor As Long
    If Not Target.ListObject Is Nothing And Target.Count = 1 Then
        Set Rng = Me.Range("T_Postes")
        If Not Intersect(Target, Rng.Columns(2)) Is Nothing Then
            Set shp = Me.Shapes.Range(Target.Offset(, -1).Text)
            lColor = IIf(Target.Value > 0, vbRed, vbGreen)
            shp.Fill.ForeColor.RGB = lColor
        End If
    End If
End Sub

Bonjour,

Merci beaucoup.

CDT.