Change Shape Color based on Cell Value (Excel VBA)

[Valeriew]

I am new to VBA and I want to make an interactive map consisting of 10 districts, where each district would be colored, for example, green if person A is assigned to that district or red if person B is assigned to that district . I used this code from other threads and there is no error in the formula, but it seems like the shape color doesn't change. Can anyone tell me what is wrong in the code?

Private Sub Worksheet_Change(ByVal Target As Range)

For i = 1 To 10

If Sheet31.Cells(i, 2) = "Person A" Then
Sheet31.Shapes.Range(Array("Praha_" & i)).Fill.ForeColor.RGB = RGB(237, 125, 49)
ElseIf Sheet31.Cells(i, 2) = "Person B" Then
Sheet31.Shapes.Range(Array("Praha_" & i)).Fill.ForeColor.RGB = RGB(255, 192, 0)
ElseIf Sheet31.Cells(i, 2) = "Person C" Then
Sheet31.Shapes.Range(Array("Praha_" & i)).Fill.ForeColor.RGB = RGB(91, 155, 23)
ElseIf Sheet31.Cells(i, 2) = "Person D" Then
Sheet31.Shapes.Range(Array("Praha_" & i)).Fill.ForeColor.RGB = RGB(165, 165, 165)
ElseIf Sheet31.Cells(i, 2) = "Person E" Then
Sheet31.Shapes.Range(Array("Praha_" & i)).Fill.ForeColor.RGB = RGB(96, 165, 165)

End If
Next i

End Sub

 

[Valeriew]

The reason why my event procedure checks if the shape exists …​

​

Anyway an optimization is necessary for the Sheet1 worksheet module :​

Function ShapeExists(V) As Boolean
         On Error Resume Next
         ShapeExists = IsObject(Shapes(V))
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
        Dim Rg As Range, Rc As Range, S$, V
        Set Rg = Intersect([A1].CurrentRegion.Columns(2), Target):  If Rg Is Nothing Then Exit Sub
    For Each Rc In Rg
            S = Rc(1, 0).Text
        If ShapeExists(S) Then
            V = Application.VLookup(Rc.Text, Sheet2.UsedRange, 3, False):  If IsError(V) Then V = 16777215
            Shapes(S).Fill.ForeColor.RGB = V
        Else
            Rc(1, 0).Font.ColorIndex = 3:  Beep
        End If
    Next
        Set Rg = Nothing
End Sub

The reason why my event procedure checks if the shape exists …​

​

Anyway an optimization is necessary for the Sheet1 worksheet module :​

Function ShapeExists(V) As Boolean
         On Error Resume Next
         ShapeExists = IsObject(Shapes(V))
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
        Dim Rg As Range, Rc As Range, S$, V
        Set Rg = Intersect([A1].CurrentRegion.Columns(2), Target):  If Rg Is Nothing Then Exit Sub
    For Each Rc In Rg
            S = Rc(1, 0).Text
        If ShapeExists(S) Then
            V = Application.VLookup(Rc.Text, Sheet2.UsedRange, 3, False):  If IsError(V) Then V = 16777215
            Shapes(S).Fill.ForeColor.RGB = V
        Else
            Rc(1, 0).Font.ColorIndex = 3:  Beep
        End If
    Next
        Set Rg = Nothing
End Sub

Wow Many Thanks for this and the previous code Marc! It works wonderfully!.

One very last question, if the 10 districts are now in C91:C100 and the person assigned is in F91:F100. How should I adjust the VBA code?

 

[Marc L]

Sheet1 worksheet module update :​

Private Sub Worksheet_Change(ByVal Target As Range)
        Dim Rg As Range, Rc As Range, S$, V
        Set Rg = Intersect([F91:F100], Target):  If Rg Is Nothing Then Exit Sub
    For Each Rc In Rg
            S = Rc(1, -2).Text
        If ShapeExists(S) Then
            V = Application.VLookup(Rc.Text, Sheet2.UsedRange, 3, False)
            Shapes(S).Fill.ForeColor.RGB = IIf(IsError(V), 16777215, V)
        Else
            Rc(1, -2).Font.ColorIndex = 3:  Beep
        End If
    Next
        Set Rg = Nothing
End Sub

 

[Valeriew]

Sheet1 worksheet module update :​

Private Sub Worksheet_Change(ByVal Target As Range)
        Dim Rg As Range, Rc As Range, S$, V
        Set Rg = Intersect([F91:F100], Target):  If Rg Is Nothing Then Exit Sub
    For Each Rc In Rg
            S = Rc(1, -2).Text
        If ShapeExists(S) Then
            V = Application.VLookup(Rc.Text, Sheet2.UsedRange, 3, False)
            Shapes(S).Fill.ForeColor.RGB = IIf(IsError(V), 16777215, V)
        Else
            Rc(1, -2).Font.ColorIndex = 3:  Beep
        End If
    Next
        Set Rg = Nothing
End Sub

Again, Many Thanks for this Marc!