Auto-update Colour Map VBA (simple fix?)

dbpatrick

New Member
Joined
Mar 12, 2009
Messages
1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strName As String
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("B9:B21")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
If Target.Address = "$B$9" Then
strName = "Freeform 106"
ElseIf Target.Address = "$B$10" Then strName = "Freeform 121"
ElseIf Target.Address = "$B$11" Then strName = "Freeform 67"
ElseIf Target.Address = "$B$12" Then strName = "Group 878"
ElseIf Target.Address = "$B$13" Then strName = "Freeform 115"
ElseIf Target.Address = "$B$14" Then strName = "Group 875"
ElseIf Target.Address = "$B$15" Then strName = "Freeform 479"
ElseIf Target.Address = "$B$16" Then strName = "Group 877"
ElseIf Target.Address = "$B$17" Then strName = "Freeform 202"
ElseIf Target.Address = "$B$18" Then strName = "Freeform 130"
ElseIf Target.Address = "$B$19" Then strName = "Group 876"
ElseIf Target.Address = "$B$20" Then strName = "Freeform 112"
Else
strName = "Group 879"
End If
If Target = 1 Then
ActiveSheet.Shapes(strName).Fill.ForeColor.RGB = RGB(255, 0, 0)
ElseIf Target = 2 Then ActiveSheet.Shapes(strName).Fill.ForeColor.RGB = RGB(255, 66, 66)
ElseIf Target = 3 Then ActiveSheet.Shapes(strName).Fill.ForeColor.RGB = RGB(255, 125, 125)
ElseIf Target = 4 Then ActiveSheet.Shapes(strName).Fill.ForeColor.RGB = RGB(255, 200, 200)
ElseIf Target = 5 Then ActiveSheet.Shapes(strName).Fill.ForeColor.RGB = RGB(230, 230, 230)
ElseIf Target = 6 Then ActiveSheet.Shapes(strName).Fill.ForeColor.RGB = RGB(200, 255, 200)
ElseIf Target = 7 Then ActiveSheet.Shapes(strName).Fill.ForeColor.RGB = RGB(150, 200, 150)
ElseIf Target = 8 Then ActiveSheet.Shapes(strName).Fill.ForeColor.RGB = RGB(75, 150, 75)
Else
If Target = 9 Then
ActiveSheet.Shapes(strName).Fill.ForeColor.RGB = RGB(25, 100, 25)
Else
MsgBox "Bitte Werte zwischen 1 und 10 eingeben"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End If
Application.ScreenUpdating = True
End Sub

Hi!

I have written this Sub in order to do the following,
1) Apply a certain colour (red-->green scale) to different countries on a map of Europe (the freeforms and groups) dependent on a number entered into the fields B9:B21.

(I say written, I mean partially pinched from elsewhere - I'm new to VBA)

That is it. Simple? Apparently not for me.

This number (B9:B21) is acquired by a VLookUp on the work sheet which recognises whether a specific percentage figure falls into a certain ranges.

What should happen is.. I enter a percentage, the percentage triggers a figure between 1-9 in B9:B21 and then the specific country changes into a nice colour.

For some reason this does not happen.

I enter the number, field B9:B21 changes but no pretty colours. It must be an easy fix!

Anybody? Very very much appreciated!

Patrick
 

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.

Forum statistics

Threads
1,203,465
Messages
6,055,577
Members
444,799
Latest member
CraigCrowhurst

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
Back
Top