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]

​

According to your attachment, evaluate this idea : instead of hardcoding colors and names,​

as you are using a drop-down list in Sheet2 so using the Sheet2 column B for the color should be better like "237,125,49" ?​

You mean instead of using "Person A" as an index to change the relative shape color, I should use the RGB "237,125,49"?

I'm sorry but that's not I what I want. It will be difficult to remember which Person is "RGB (237,125,49)" or which Person is "RGB (255, 192, 0)"

 

[Marc L]

​

It's not what I wrote : in Sheet2 column B should be the 'RGB' color according to the name in column A …​

​

Proceeding like this does not need to amend the code in case of any change.​

 

[Valeriew]

​

It's not what I wrote : in Sheet2 column B should be the 'RGB' color according to the name in column A …​

​

Proceeding like this does not need to amend the code in case of any change.​

I'm sorry if I don't understand you correctly, but please correct me if I'm wrong. So you mean to add another column (column C) with formula to change the cell value based on column B? (please refer to the picture below).

Column A consists a list of name of the 10 districts, and Column B is the Person assigned to that district (but can be changed who is assigned to that district). Thus, I don't quite understand what do you mean by "column B should be the 'RGB' color according to the name in column A".

 

[Marc L]

​

No as since post #10 I wrote in Sheet2 and column B and I never stated about any formula ‼​

​

As my solution works since last century but with good enough readers only …​

 

[Valeriew]

​

No as I wrote in Sheet2 and column B ‼​

Ah apologize, my bad, I misread it as Sheet1. Now I understand your point, if so, then how the VBA code should be written?

 

[Marc L]

1. Paste this event code to the Sheet2 worksheet module :
   
   

   Private Sub Worksheet_Change(ByVal Target As Range)
           Dim V, W
       With Target
           If .CountLarge > 1 Or .Column = 1 Or .Column > 3 Then Exit Sub
           Application.EnableEvents = False
       If .Column = 2 Then
           If .Text Like "*,*,*" Then
               V = Split(.Text, ",")
           For Each W In V
               If W < 0 Or W > 255 Then Beep: .Range("A1:B1").ClearContents: .Select: Exit For
           Next
               If IsEmpty(W) Then .Cells(1, 2).Value2 = RGB(V(0), V(1), V(2))
           Else
              .Range("A1:B1").ClearContents:  Beep:  .Select
           End If
       ElseIf .Column = 3 Then
           Application.Undo
       End If
           Application.EnableEvents = True
       End With
   End Sub

   
   
2. Once Sheet2 module is updated you can add the RGB sequences in column B and when valid their relative values appear in column C …
   
   
3. Paste this event procedure to 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
       With Target
           Set Rg = Intersect([B1:B10], .Cells):  If Rg Is Nothing Then Exit Sub
       For Each Rc In Rg
               S = Rc(1, 0).Text
           If ShapeExists(S) Then
               V = Application.VLookup(.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 With
   End Sub

   
   
4. Save your workbook as binary format (.xlsb) …

 

[Fluff]

Welcome to the MrExcel Message Board!

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Change Shape Color based on Cell Value (Excel VBA)
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

 

[Marc L]

(removed)

 

[KOKOSEK]

In file from GoogleDrive, there is incorrect shape name 'Praha 2' instead of 'Praha_2'.

 

[Marc L]

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