Issues with code to change textbox fill colour based on a cell value

[Radchek]

I'm using Excel 2003 to produce a UK map showing areas pinpointed with textboxes that are coloured Red/Amber/Green.

In my worksheet there are 100+ Text Boxes on an overlay of a UK map labeled "1" to "150"; they are also named "Text Box 001" to "Text Box 150" respectively.

Column P, rows 1 to 150 show numbers obtained via a vlookup formula based on text in the adjacent column.
I'm trying to automatically change each textbox based on the number in Column P.

i.e. 2.5 or less should colour the textbox red
Greater than 2.5 and less than 2.75 should colour the textbox yellow
Greater than 2.75 should colour the the text box green
Anything else should colour the textbox white

so if it worked:
P19 is 4 so 'Text Box 019' should be green
P101 is 1.1 so 'Text Box 101' should be red
P140 is empty so 'Text Box 140' should be coloured white, etc.

I found a semi-relevant post on the forum and used this code:

Private Sub Worksheet_Change(ByVal Target As Range)
     
    If Not Intersect(Target, Range("P1")) Is Nothing Then
    ActiveSheet.Shapes("Text Box 001").Fill.ForeColor.RGB = vbWhite
        If IsNumeric(Target.Value) Then
            If Target.Value <= 2.5 Then
                ActiveSheet.Shapes("Text Box 001").Fill.ForeColor.RGB = vbRed
            ElseIf Target.Value > 2.5 And Target.Value < 2.75 Then
                ActiveSheet.Shapes("Text Box 001").Fill.ForeColor.RGB = vbYellow
            Else
                ActiveSheet.Shapes("Text Box 001").Fill.ForeColor.RGB = vbGreen
            End If
        End If
    End If
End Sub

Problem 1: The code doesn't seem to register the value of the vlookup result - I just get red text boxes. If I type over the vlookup result with the same value it then starts working.

Problem 2: Is there an easy way to change yellow to Amber? vbAmber results in a black box.

Problem 3: I'm guessing repeating that bit of code 150 times to colour each respective textbox is bad coding. Given that the textbox names are cosistant, is there a workaround to make it more concise?

Thanks in advance!

 

[par60056]

Here is something that may help.

Rather than checking the intersection with a cell, check the entire column. Then loop through the rows in the target range and look at the values in column P. Generally there is probably only 1 value change but this should allow pasting a series of values at one time.

I also changed your colors from restrictive constants to calls to the RGB function which allows values of 0-255 for each parameter and lets you make any color.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim shapeName As String
Dim currRow As Long
     
    If Not Intersect(Target, Columns(16)) Is Nothing Then
        For currRow = 1 To Target.Rows.Count
            shapeName = "Text Box " & Format(Target.Row + currRow - 1, "000")
            ActiveSheet.Shapes(shapeName).Fill.ForeColor.RGB = vbWhite
            If IsNumeric(Cells(Target.Row + currRow - 1, 16)) Then
                If Cells(Target.Row + currRow - 1, 16) <= 2.5 Then
                    ActiveSheet.Shapes(shapeName).Fill.ForeColor.RGB = RGB(255, 0, 0)
                ElseIf Cells(Target.Row + currRow - 1, 16) > 2.5 And Cells(Target.Row + currRow - 1, 16) < 2.75 Then
                    ActiveSheet.Shapes(shapeName).Fill.ForeColor.RGB = RGB(255, 180, 0)
                Else
                    ActiveSheet.Shapes(shapeName).Fill.ForeColor.RGB = RGB(0, 255, 0)
                End If
            End If
        Next
    End If
End Sub

 

[Radchek]

Great stuff, that solved all three of my problems perfectly.

Thanks very much for taking the time to help me out par60056! Much appriciated!

 

[par60056]

Glad to help out.

You were very close and just needed a little tuning.

I worked in Excel VBA for years before attempting event processing. You are starting with some tricky stuff.