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

Radchek

New Member
Joined
Apr 17, 2013
Messages
9
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:

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!
 

Some videos you may like

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.

par60056

Well-known Member
Joined
Jul 26, 2012
Messages
1,581
Office Version
  1. 2011
  2. 2010
Platform
  1. Windows
  2. MacOS
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.

Code:
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

New Member
Joined
Apr 17, 2013
Messages
9
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

Well-known Member
Joined
Jul 26, 2012
Messages
1,581
Office Version
  1. 2011
  2. 2010
Platform
  1. Windows
  2. MacOS
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,875
Messages
5,627,412
Members
416,245
Latest member
Xterminat

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top