Change shape color based on cell value in multiple columns

[lai_arceo]

Hello.

I want to change the color of the shapes in columns D, I, N, S, X and AC based on the values of columns E, J, O, T, Y and AD respectively. If a cell in latter columns is:

B - shape color should be red
K - shape color should be blue
BIN - shape color should be green

Your help will be much appreciated.

Sample File.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD
1
2					B					B					B					B					B					B
3
4
5
6					K					B					BIN					K					BIN					BIN
7
8
9
10
11					K					B					BIN					K					BIN					BIN
12
1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
R10	Cell Value	="K"	text	NO
R10	Cell Value	="B"	text	NO
P12	Cell Value	="K"	text	NO
P12	Cell Value	="B"	text	NO
P10:P11	Cell Value	="K"	text	NO
P10:P11	Cell Value	="B"	text	NO
AB10	Cell Value	="K"	text	NO
AB10	Cell Value	="B"	text	NO
Z10	Cell Value	="K"	text	NO
Z10	Cell Value	="B"	text	NO
Z12	Cell Value	="K"	text	NO
Z12	Cell Value	="B"	text	NO
Z11	Cell Value	="K"	text	NO
Z11	Cell Value	="B"	text	NO
W10	Cell Value	="K"	text	NO
W10	Cell Value	="B"	text	NO
U10	Cell Value	="K"	text	NO
U10	Cell Value	="B"	text	NO
U12	Cell Value	="K"	text	NO
U12	Cell Value	="B"	text	NO
U11	Cell Value	="K"	text	NO
U11	Cell Value	="B"	text	NO
M10	Cell Value	="K"	text	NO
M10	Cell Value	="B"	text	NO
K10	Cell Value	="K"	text	NO
K10	Cell Value	="B"	text	NO
K12	Cell Value	="K"	text	NO
K12	Cell Value	="B"	text	NO
K11	Cell Value	="K"	text	NO
K11	Cell Value	="B"	text	NO
H10	Cell Value	="K"	text	NO
H10	Cell Value	="B"	text	NO
C10	Cell Value	="K"	text	NO
C10	Cell Value	="B"	text	NO
F12	Cell Value	="K"	text	NO
F12	Cell Value	="B"	text	NO
A12	Cell Value	="K"	text	NO
A12	Cell Value	="B"	text	NO
F10	Cell Value	="K"	text	NO
F10	Cell Value	="B"	text	NO
F11	Cell Value	="K"	text	NO
F11	Cell Value	="B"	text	NO
A10:A11	Cell Value	="K"	text	NO
A10:A11	Cell Value	="B"	text	NO
B9:D9,G9:I9,L9:N9,V9:X9,AA9:AC9,Q9:S9	Cell Value	="K"	text	NO
B9:D9,G9:I9,L9:N9,V9:X9,AA9:AC9,Q9:S9	Cell Value	="B"	text	NO
R5	Cell Value	="K"	text	NO
R5	Cell Value	="B"	text	NO
P7	Cell Value	="K"	text	NO
P7	Cell Value	="B"	text	NO
P3	Cell Value	="K"	text	NO
P3	Cell Value	="B"	text	NO
P5:P6	Cell Value	="K"	text	NO
P5:P6	Cell Value	="B"	text	NO
P1:P2,R1	Cell Value	="K"	text	NO
P1:P2,R1	Cell Value	="B"	text	NO
AB5	Cell Value	="K"	text	NO
AB5	Cell Value	="B"	text	NO
Z5	Cell Value	="K"	text	NO
Z5	Cell Value	="B"	text	NO
AB1	Cell Value	="K"	text	NO
AB1	Cell Value	="B"	text	NO
Z1	Cell Value	="K"	text	NO
Z1	Cell Value	="B"	text	NO
Z7	Cell Value	="K"	text	NO
Z7	Cell Value	="B"	text	NO
Z6	Cell Value	="K"	text	NO
Z6	Cell Value	="B"	text	NO
Z3	Cell Value	="K"	text	NO
Z3	Cell Value	="B"	text	NO
Z2	Cell Value	="K"	text	NO
Z2	Cell Value	="B"	text	NO
W5	Cell Value	="K"	text	NO
W5	Cell Value	="B"	text	NO
U5	Cell Value	="K"	text	NO
U5	Cell Value	="B"	text	NO
W1	Cell Value	="K"	text	NO
W1	Cell Value	="B"	text	NO
U1	Cell Value	="K"	text	NO
U1	Cell Value	="B"	text	NO
U7	Cell Value	="K"	text	NO
U7	Cell Value	="B"	text	NO
U6	Cell Value	="K"	text	NO
U6	Cell Value	="B"	text	NO
U3	Cell Value	="K"	text	NO
U3	Cell Value	="B"	text	NO
U2	Cell Value	="K"	text	NO
U2	Cell Value	="B"	text	NO
M5	Cell Value	="K"	text	NO
M5	Cell Value	="B"	text	NO
K5	Cell Value	="K"	text	NO
K5	Cell Value	="B"	text	NO
M1	Cell Value	="K"	text	NO
M1	Cell Value	="B"	text	NO
K1	Cell Value	="K"	text	NO
K1	Cell Value	="B"	text	NO
H1	Cell Value	="K"	text	NO
H1	Cell Value	="B"	text	NO
K7	Cell Value	="K"	text	NO
K7	Cell Value	="B"	text	NO
K6	Cell Value	="K"	text	NO
K6	Cell Value	="B"	text	NO
H5	Cell Value	="K"	text	NO
H5	Cell Value	="B"	text	NO
C5	Cell Value	="K"	text	NO
C5	Cell Value	="B"	text	NO
F7	Cell Value	="K"	text	NO
F7	Cell Value	="B"	text	NO
A7	Cell Value	="K"	text	NO
A7	Cell Value	="B"	text	NO
K3	Cell Value	="K"	text	NO
K3	Cell Value	="B"	text	NO
F3	Cell Value	="K"	text	NO
F3	Cell Value	="B"	text	NO
A3	Cell Value	="K"	text	NO
A3	Cell Value	="B"	text	NO
F5	Cell Value	="K"	text	NO
F5	Cell Value	="B"	text	NO
K2	Cell Value	="K"	text	NO
K2	Cell Value	="B"	text	NO
F6	Cell Value	="K"	text	NO
F6	Cell Value	="B"	text	NO
F2	Cell Value	="K"	text	NO
F2	Cell Value	="B"	text	NO
F1	Cell Value	="K"	text	NO
F1	Cell Value	="B"	text	NO
A5:A6	Cell Value	="K"	text	NO
A5:A6	Cell Value	="B"	text	NO
A1:A2,C1	Cell Value	="K"	text	NO
A1:A2,C1	Cell Value	="B"	text	NO
B4:D4,G4:I4,L4:N4,V4:X4,AA4:AC4,Q4:S4	Cell Value	="K"	text	NO
B4:D4,G4:I4,L4:N4,V4:X4,AA4:AC4,Q4:S4	Cell Value	="B"	text	NO

 

[DanteAmor]

You can run the following macro to color all the shapes.

Sub ShapeColor()
  Dim shp As Shape
  For Each shp In ActiveSheet.Shapes
    With shp.Fill.ForeColor
      Select Case shp.TopLeftCell.Offset(, 1).Value
        Case "B":   .RGB = RGB(255, 0, 0)
        Case "K":   .RGB = RGB(0, 0, 255)
        Case "BIN": .RGB = RGB(0, 255, 0)
      End Select
    End With
  Next
End Sub

HOW TO INSTALL MACROs
If you are new to macros, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. To use the macro, go back to the worksheet with your data on it and press ALT+F8, select the macro name (ShapeColor) from the list that appears and click the Run button. The macro will execute and perform the action(s) you asked for. If you will need to do this again in this same workbook, and if you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.xlsm) and answer the "do you want to enable macros" question as "Yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.
------------------------------------

Or also put the following code in the events of your sheet. Every time you change the value of one of the cells, the shape will automatically change color.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, c As Range
  Dim shp As Shape
  
  Set rng = Intersect(Target, Range("E:E, J:J, O:O, T:T, Y:Y, AD:AD"))
  If Not rng Is Nothing Then
    For Each c In rng
      For Each shp In ActiveSheet.Shapes
        If Not Intersect(shp.TopLeftCell, c.Offset(, -1)) Is Nothing Then
          Select Case c.Value
            Case "B":   shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
            Case "K":   shp.Fill.ForeColor.RGB = RGB(0, 0, 255)
            Case "BIN": shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
          End Select
          Exit For
        End If
      Next
    Next
  End If
End Sub

SHEET EVENT
Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.

 

[lai_arceo]

You can run the following macro to color all the shapes.

Sub ShapeColor()
  Dim shp As Shape
  For Each shp In ActiveSheet.Shapes
    With shp.Fill.ForeColor
      Select Case shp.TopLeftCell.Offset(, 1).Value
        Case "B":   .RGB = RGB(255, 0, 0)
        Case "K":   .RGB = RGB(0, 0, 255)
        Case "BIN": .RGB = RGB(0, 255, 0)
      End Select
    End With
  Next
End Sub

HOW TO INSTALL MACROs
If you are new to macros, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. To use the macro, go back to the worksheet with your data on it and press ALT+F8, select the macro name (ShapeColor) from the list that appears and click the Run button. The macro will execute and perform the action(s) you asked for. If you will need to do this again in this same workbook, and if you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.xlsm) and answer the "do you want to enable macros" question as "Yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.
------------------------------------

Or also put the following code in the events of your sheet. Every time you change the value of one of the cells, the shape will automatically change color.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, c As Range
  Dim shp As Shape
 
  Set rng = Intersect(Target, Range("E:E, J:J, O:O, T:T, Y:Y, AD:AD"))
  If Not rng Is Nothing Then
    For Each c In rng
      For Each shp In ActiveSheet.Shapes
        If Not Intersect(shp.TopLeftCell, c.Offset(, -1)) Is Nothing Then
          Select Case c.Value
            Case "B":   shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
            Case "K":   shp.Fill.ForeColor.RGB = RGB(0, 0, 255)
            Case "BIN": shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
          End Select
          Exit For
        End If
      Next
    Next
  End If
End Sub

SHEET EVENT
Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.

This worked great! Thank you so much, @DanteAmor!

 

[lai_arceo]

@DanteAmor - I have another question though. The values "BIN,K,B" are results of a cell calculation instead of a manual input. How can I trigger the macro to run if "Worksheet_Calculate" is used instead of "Worksheet_Change"?

 

[DanteAmor]

The values "BIN,K,B" are results of a cell calculation instead of a manual input.

So which cells do you manually modify?
Put here the formulas that you use to obtain the BIN, K and B values.

 

[lai_arceo]

@DanteAmor Here's a copy of the table. Hope this helps.

STUDENT.xlsm
	A	B
1	1
1

Cell Formulas
Range	Formula
A1	A1	=LEFT(E3,1)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A1:A2,C1	Cell Value	="K"	text	NO
A1:A2,C1	Cell Value	="B"	text	NO

The values BIN, K & B are results based on the Student's ID number, entered in the cells, E1, J1, O1, T1, E5, J5, O5, T5....

 

[DanteAmor]

I do not understand. Which cells do you manually modify so that the B, K and BIM values appear?

 

[lai_arceo]

I do not understand. Which cells do you manually modify so that the B, K and BIM values appear?

Cells E1, J1, O1, T1, E5, J5, O5, T5.

 

[DanteAmor]

Try this:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, c As Range
  Dim shp As Shape
  
  Set rng = Intersect(Target, Range("E:E, J:J, O:O, T:T, Y:Y, AD:AD"), Range("1:1,5:5,10:10"))
  
  If Not rng Is Nothing Then
    For Each c In rng
      For Each shp In ActiveSheet.Shapes
        If Not Intersect(shp.TopLeftCell, c.Offset(1, -1)) Is Nothing Then
          Select Case c.Value
            Case "B":   shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
            Case "K":   shp.Fill.ForeColor.RGB = RGB(0, 0, 255)
            Case "BIN": shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
          End Select
          Exit For
        End If
      Next
    Next
  End If
End Sub

 

[lai_arceo]

Try this:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rng As Range, c As Range
  Dim shp As Shape
 
  Set rng = Intersect(Target, Range("E:E, J:J, O:O, T:T, Y:Y, AD:AD"), Range("1:1,5:5,10:10"))
 
  If Not rng Is Nothing Then
    For Each c In rng
      For Each shp In ActiveSheet.Shapes
        If Not Intersect(shp.TopLeftCell, c.Offset(1, -1)) Is Nothing Then
          Select Case c.Value
            Case "B":   shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
            Case "K":   shp.Fill.ForeColor.RGB = RGB(0, 0, 255)
            Case "BIN": shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
          End Select
          Exit For
        End If
      Next
    Next
  End If
End Sub

Thank you so much, @DanteAmor!