change shapes colour dependant on cell value

[fireslguk]

i have a number of shapes example Oval 1 to Oval 10

I want each shape separately linked to a cell so when the cell is zero shape is filled red, value 1 to 20 orange and 21 above green

So 10 cells being different numbers and the linked shapes being different colours


I can do the VBA for one shape but cannot do others

 

[sykes]

This will work for you.
Because you've not stated which 10 cells refer to your shapes, or what your shape index numbers are, I've had to guess A1:A10. Change accordingly.
You just need to figure out your shape indexes on the sheet, and change my code accordingly; eg, if your first shape is actually shape 1, and your "Linked" cell was in row 1, then you'd use this instead:

Shapes(Target.Row ).Fill.ForeColor.RGB = vbRed

In my case, however, the first shape I wanted colouring, is actually "shape 7" - hence me adding 6 to the row number, in order to refer to it.
Also, change the RGB values, to suite.

NB always test on a copy of your work, first.

Private Sub Worksheet_Change(ByVal Target As Range)

   If Not Intersect(Target, Range("A1:A10")) Is Nothing Then

        With Me
   
            Select Case Target.Value
                Case 0
                    .Shapes(Target.Row + 6).Fill.ForeColor.RGB = vbRed
                Case Is < 21
                    .Shapes(Target.Row + 6).Fill.ForeColor.RGB = RGB(255, 165, 0)
                Case Else
                    .Shapes(Target.Row + 6).Fill.ForeColor.RGB = vbGreen
   
            End Select
        End With
    End If
End Sub

 

[fireslguk]

Hi Thankyou for reply yes so numerical values in A1:A:10

Shape “Oval 1” to fill colour based on A1 value
Shape “Oval 2” to fill colour based on A2 Value
Shape “Oval 3” to fill colour based on A3 Value
And so on

So I look at your code and think how can I do this ?‍

 

[sykes]

This should work. As before - test on a copy, first.

Private Sub Worksheet_Change(ByVal Target As Range)

   If Not Intersect(Target, Range("A1:A10")) Is Nothing Then

        With Me
   
            Select Case Target.Value
                Case 0
                    .Shapes ("Oval" & Target.Row).Fill.ForeColor.RGB = vbRed
                Case Is < 21
                    .Shapes ("Oval" & Target.Row).Fill.ForeColor.RGB = RGB(255, 165, 0)
                Case Else
                     .Shapes ("Oval" & Target.Row).Fill.ForeColor.RGB = vbGreen
   
            End Select
        End With
    End If
End Sub

 

[fireslguk]

**** cannot get this to work, comes up with error

Run-time error '-2147024809 (80070057)':

The item with the specified name wasn't found

 

[Fluff]

Try putting a space after the word "Oval "

 

[fireslguk]

Try putting a space after the word "Oval "

boom that worked however instead Oval what do i put for freeform shapes ?

 

[Fluff]

The name of the shape as long as they all have a number at the end that reflects what row in col A affects them.

 

[fireslguk]

Hey Fluff

If I wanted to add another criteria would that work example

value zero red
1 to 10 amber
10 to 40 blue
Above 40 Green

 

[Fluff]

You can do that like

Private Sub Worksheet_Change(ByVal Target As Range)

   If Not Intersect(Target, Range("A1:A10")) Is Nothing Then

        With Me
   
            Select Case Target.Value
                Case 0
                    .Shapes("Oval " & Target.Row).Fill.ForeColor.RGB = vbRed
                Case 1 To 10
                    .Shapes("Oval " & Target.Row).Fill.ForeColor.RGB = RGB(255, 165, 0)
                Case 11 To 40
                     .Shapes("Oval " & Target.Row).Fill.ForeColor.RGB = vbGreen
               Case Else
                     .Shapes("Oval " & Target.Row).Fill.ForeColor.RGB = vbGreen
            End Select
        End With
    End If
End Sub

Just change the colours to what you want.