Change Shape's Format, Color, Transparency, Based on Cell Values

[PilotP]

Hello Experts,

How can I use a Macro to change Shape's Format, Color, Transparency, based on a Cell Values?

Example:

• The table shows the status of Houses 1 to 10.
• The Color codes are shown in header for each stage.
• Full color fill if the stage is completed and patterned if the stage is in progress.

How do I use a Macro to refresh the Shapes Formatting on the Map with the new data in the table?

Thanks in advance for your help.
Pouria,

 

[gshock]

Hi @PilotP .

Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.​

For the proper functioning of the macro you must do this with your houses.

1. Each house is composed of 3 parts, foundation (F), Walls (W) and Roof (R), so you must name each part for each house.​

2. Follow the example of house 1 to name each part of each house.​

In the Name Box you must write each name.​

​

House-1-F for the Foundation​

View attachment 91321​

​

House-1-W for the Walls​

View attachment 91324​

​

House-1-R for the Roof​

View attachment 91326​

And so for each house.
-----------------------------------------------

If you named all the parts of the houses properly the macro will work without problems.
If you have any name errors, then the macro will send a message like this:
View attachment 91327

Then you will have to verify given name of each part of each house.
It's a tricky part of the process, but it's something that has to be done.


Put all the following code in a module and run the PaintingTheHouse macro.

Sub PaintingTheHouse()
  Dim shpf As Shape, shpw As Shape, shpr As Shape
  Dim c As Range
 
  For Each c In Range("C7:C16")
    Set shpf = ActiveSheet.Shapes(c.Value & "-F")
    Set shpw = ActiveSheet.Shapes(c.Value & "-W")
    Set shpr = ActiveSheet.Shapes(c.Value & "-R")
 
    If c.Offset(, 1) = "Completed" Then Call PaintFore("D", shpf, "", shpw, "", shpr)
    If c.Offset(, 2) = "Completed" Then Call PaintFore("E", shpf, "E", shpw, "", shpr)
    If c.Offset(, 3) = "Completed" Then Call PaintFore("F", shpf, "F", shpw, "F", shpr)
    If c.Offset(, 4) = "Completed" Then Call PaintFore("G", shpf, "G", shpw, "G", shpr)
    If c.Offset(, 5) = "Completed" Then Call PaintFore("H", shpf, "H", shpw, "H", shpr)
  
    If c.Offset(, 1) = "In-Progress" Then Call PaintPattern("D", shpf)
    If c.Offset(, 2) = "In-Progress" Then Call PaintPattern("E", shpw)
    If c.Offset(, 3) = "In-Progress" Then Call PaintPattern("F", shpr)
  Next
End Sub

Sub PaintFore(col1, shpf, col2, shpw, col3, shpr)
  With shpf.Fill.ForeColor
    If col1 = "" Then .RGB = RGB(255, 255, 255) Else .RGB = Range(col1 & 6).Interior.Color
  End With
  With shpw.Fill.ForeColor
    If col2 = "" Then .RGB = RGB(255, 255, 255) Else .RGB = Range(col2 & 6).Interior.Color
  End With
  With shpr.Fill.ForeColor
    If col3 = "" Then .RGB = RGB(255, 255, 255) Else .RGB = Range(col3 & 6).Interior.Color
  End With
End Sub

Sub PaintPattern(col As String, shp As Shape)
  With shp.Fill
    .Visible = msoTrue
    .ForeColor.RGB = Range(col & 6).Interior.Color
    .BackColor.ObjectThemeColor = msoThemeColorBackground1
    .Patterned msoPatternWideUpwardDiagonal
  End With
End Sub

The result will be something like this:
View attachment 91328
----------------------------------------

A plus. If you want to unpaint the houses, execute this macro, you must put it in the same module.

Sub UnPaintingTheHouse()
  Dim shpf As Shape, shpw As Shape, shpr As Shape
  Dim c As Range
 
  For Each c In Range("C7:C16")
    Set shpf = ActiveSheet.Shapes(c.Value & "-F")
    Set shpw = ActiveSheet.Shapes(c.Value & "-W")
    Set shpr = ActiveSheet.Shapes(c.Value & "-R")
    Call PaintFore("", shpf, "", shpw, "", shpr)
  Next
End Sub

The result will be something like this:
View attachment 91329

---------------------------------------------
The range of cells to process is from C7 to C16 but you can adjust it in this line of the macro:

For Each c In Range("C7:C16")

---------------------------------------------
I share my evidence file so you can see the names of all the parts of all the houses.
PaintingHouses

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

Dante, tremendously helpful. Thank you. I incorporated this in a slightly different application to fill the shapes for vibration severity in an engineering report. I really appreciate all the effort and hard work that you put into this.

Here I did a good job for nothing.
I hope someone else helps.

Definitely not "for nothing". This has been a huge time saver.