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

P

PilotP

New Member
Joined
May 9, 2023
Messages
6
Office Version
  1. 365
Platform
  1. Windows
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,
 

Attachments

  • Macro Example.PNG
    Macro Example.PNG
    64.3 KB · Views: 28

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
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​
1683693928292.png
​
House-1-W for the Walls​
1683694096344.png
​
House-1-R for the Roof​
1683694169822.png

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:
1683694452203.png


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.
VBA Code: 
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:
1683694600829.png

----------------------------------------

A plus. If you want to unpaint the houses, execute this macro, you must put it in the same module.
VBA Code: 
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:
1683694753367.png


---------------------------------------------
The range of cells to process is from C7 to C16 but you can adjust it in this line of the macro:
Rich (BB code): 
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
--------------
 
Upvote 2
DanteAmor said:
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​
​
House-1-W for the Walls​
​
House-1-R for the Roof​

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.
VBA Code: 
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.
VBA Code: 
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:
Rich (BB code): 
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
--------------
Click to expand...
Thank you Dante,

I appreciate your time and kind response.

I couldn't replicate the same in the report I'm trying to make. Is there a simpler code for a VBA beginner like me?

Also in in your file the "In-progress" status cant update the colors,

What if I get rid of the pattern for "In Progress" and just want to have solid fill but need to make them color coded for status? i.e. for 1 shape "Foundation" has 4 steps Excavated (Yellow), Steel Work (Blue), Concrete (Gray) Completed (Green) Then Same for Wall with 3 Steps, Same for Roof with 3 steps. etc.
 
Upvote 0
Here I did a good job for nothing.
I hope someone else helps.

PilotP said:
Is there a simpler code for a VBA beginner like me?
Click to expand...
Instead of having many colors or stages in the drawing, perhaps it is enough, instead of foundation (F), Walls (W) and Roof (R), to have only one figure and paint that figure in different colors.
You are only complicating your job.

Here's something simpler.
VBA Code: 
Sub painting()
  ActiveSheet.Shapes("house1").Fill.ForeColor.RGB = Range("B3").Interior.Color
End Sub

I will try to explain it with the following image.
1684251594811.png

Do the image for each figure.
Good luck.
 
Upvote 0
DanteAmor said:
Here I did a good job for nothing.
I hope someone else helps.


Instead of having many colors or stages in the drawing, perhaps it is enough, instead of foundation (F), Walls (W) and Roof (R), to have only one figure and paint that figure in different colors.
You are only complicating your job.

Here's something simpler.
VBA Code: 
Sub painting()
  ActiveSheet.Shapes("house1").Fill.ForeColor.RGB = Range("B3").Interior.Color
End Sub

I will try to explain it with the following image.
View attachment 91702
Do the image for each figure.
Good luck.
Click to expand...
Mate, I'm sure it's my lack of knowledge in Macros/VBA and I thank you for your time and good job.

But, just FYI, Looks like I'm missing something in plain sight. because even the simple code seem to struggle!

1684287398629.png
 
Upvote 0
PilotP said:
I'm sure it's my lack of knowledge in Macros/VBA
Click to expand...
That is not the problem, check the following and you will see what the problem is:


1684289171953.png


without quotation marks
1684289248577.png



PilotP said:
But, just FYI, Looks like I'm missing something in plain sight.
Click to expand...
That's right, it's something in plain sight, it shouldn't have quotes.
PilotP said:
... because even the simple code seem to struggle!
Click to expand...
The problem is not the code. :cool:
 
Upvote 1
DanteAmor said:
That is not the problem, check the following and you will see what the problem is:


View attachment 91742

without quotation marks
View attachment 91744



That's right, it's something in plain sight, it shouldn't have quotes.

The problem is not the code. :cool:
Click to expand...
🙃🥸😬 Plain sight indeed!!!

I fully understand your initial code was the smart way with using the "Set" and etc. but for rookie's like me I'll take baby steps with the simplified one for now :) Many Many thanks mate

And if I may ask one last favor :)

Can you give a code to make a shape invisible? or No-Fill with 100% transparency? based on a cell Value, like: If "C10"="completed" then shape is invisible
 
Upvote 0
And is it possible to show the text from the same cell inside the shape? I just need 3 characters to be copied across same way the fill color does.
 
Upvote 0
PilotP said:
a code to make a shape invisible?
Click to expand...
VBA Code: 
ActiveSheet.Shapes("house1").Visible = False

Visible:
VBA Code: 
ActiveSheet.Shapes("house1").Visible = TRUE
-----------------------------------------------------------------------------

PilotP said:
No-Fill with 100% transparency?
Click to expand...
VBA Code: 
ActiveSheet.Shapes("house1").Fill.Transparency = 1

Solid:
VBA Code: 
ActiveSheet.Shapes("house1").Fill.Transparency = 0
-----------------------------------------------------------------------------

PilotP said:
is it possible to show the text from the same cell inside the shape? I just need 3 characters
Click to expand...
VBA Code: 
ActiveSheet.Shapes("house1").TextFrame2.TextRange.Text = Left(Range("B3").Value, 3)

Font color:
VBA Code: 
ActiveSheet.Shapes("house1").TextFrame.Characters.Font.Color = Range("B3").Font.Color

😇
 
Upvote 1
Solution
DanteAmor said:
VBA Code: 
ActiveSheet.Shapes("house1").Visible = False

Visible:
VBA Code: 
ActiveSheet.Shapes("house1").Visible = TRUE
-----------------------------------------------------------------------------


VBA Code: 
ActiveSheet.Shapes("house1").Fill.Transparency = 1

Solid:
VBA Code: 
ActiveSheet.Shapes("house1").Fill.Transparency = 0
-----------------------------------------------------------------------------


VBA Code: 
ActiveSheet.Shapes("house1").TextFrame2.TextRange.Text = Left(Range("B3").Value, 3)

Font color:
VBA Code: 
ActiveSheet.Shapes("house1").TextFrame.Characters.Font.Color = Range("B3").Font.Color

😇
Click to expand...
LEGENDARY!!!! Thanks for being very generous with your time and knowledge
 
Upvote 1
You must log in or register to reply here.

Similar threads

G
  • Question
Faster way to populate shape names?
Replies
5
Views
349
gshock
G
B
  • Question
Event code to give message box and change color of auto-shape
Replies
4
Views
187
bh24524
B
M
  • Question
VBA Event help, change shape of color as per option selections
Replies
5
Views
205
Jaafar Tribak
Jaafar Tribak
T
  • Question
Move a shape based on Cell value. If cell is less than another shape moves up, if cell is more than another cell moved down.
Replies
5
Views
85
jolivanes
jolivanes
S
  • Question
Adding Shapes on every cell based on cell value.
Replies
3
Views
389
duggie33
D

Forum statistics

Threads
1,215,096
Messages
6,123,074
Members
449,093
Latest member
ripvw

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top