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