Changing colour of autoshapes

[colmcg]

Is it possible to conditionally format the colour of an autoshape depending on the value in a cell?

Searching this forum I have managed to link an autoshape to display the cell value (add text, click formula bar, =cell ref) but I would also like the autoshapes colour to change based on the value in the cell. e.g. If cell value is between 5% & 10% then colour green, if cell value is between 11% and 15% then blue etc.

I will probably have about 50 autoshapes that I wish to apply this to. Also there will be different kinds of autoshapes - e.g. squares, rectangles, circles.

Can anyone help?

 

[erik.van.geit]

Hi,

you could use something like

Set Sh = ActiveSheet.Shapes("whatever")
    Select Case Range("A1")
    Case 0 to .15 '0 to 15%
    Sh.Fill.ForeColor.SchemeColor = 51
    Case .15 to .25
    'etcetera
    End Select

so, take a look at "Select Case"
If you need more help, it would be good to show the code you are using.

kind regards,
Erik

 

[colmcg]

Erik, thanks for your reply.

I don't actually have any code yet, in fact I haven't even set up a spreadsheet yet. I was posting to find out if it was possible to change an autoshapes colour using a value in a cell. If it was possible I was then going to try and create a spreadsheet.

Since posting I have done a few further searches and it seems VBA is the only way to achieve what I want. I have looked at a couple of other posts but cant adapt them for my project.

VBA is not one of my strong points, beginner would best describe my ability.

I am now having a look at Select Case but would be grateful for any further advice.

Regards

Colin

 

[Greg Truby]

Colin,

You may also find this thread helpful. (Or maybe just confusing?) It describes how to use VBA to create a scale of colors that blend from red to blue in your pallet. Sorta makes assigning colors based on value a little easier.<hr />

Heya, Erik!

 

[colmcg]

Greg, you were right I found the thread confusing (my limited VBA to blame). Thanks for looking at the post.

What I have in mind is creating a floor plan using autoshapes. I have managed to get a cell value appear in an autoshape but thought it would be visually more appealing if I could get an autoshapes colour to change to represent different values.

For example if the cell value was between 1 & 5 then the autoshape would turn red, if the cell value was between 6 & 10 then a different colour, between 11 & 15 then a different colour, etc, etc.

I haven't created a spreadsheet yet as I needed to find out if it was possible to do this. Armed with this information I was then going to tackle setting up a spreadsheet.

I would be grateful for any tips to point me in the right direction. I must warn you my VBA knowledge is minimal (but always looking to learn!)

Thanks in advance

Colin

 

[erik.van.geit]

I am now having a look at Select Case but would be grateful for any further advice.

did you try the codesnippet I gave you
create a shape, name it "whatever" and run the code, you received earlier

use the macrorecorder to learn more about syntax ...
don't forget the helpfiles

I changed the code according to your last post

Set Sh = ActiveSheet.Shapes("whatever") 
    Select Case Range("A1") 
    Case 1 to 5 
    Sh.Fill.ForeColor.SchemeColor = 51 
    Case 6 to 10
    'etcetera 
    End Select

if the "number-ranges" are regular like in your last post (1 to 5, 6 to 10, ...) there might be other options

kind regards,
Erik

 

[Greg Truby]

How are you assigning the values to the autoshapes? By code? Or by hand? How can you know "this cell is linked to that shape". I'm not seeing a property of shape objects that will return a shape's "formula".

 

[colmcg]

Erik, Greg.

Thank you both for your replys. Sorry it's taken so long to re-post but I've been at work and I don't have internet access there.

Greg, I'm not sure if the cell is 'linked' to the autoshape. What I managed to achieve was display the value of A1 in the autoshape by clicking 'add text' and then reference the cell.

Erik, both your codes seem to achieve what I want. By running your code I've managed to change an autoshapes colour using different values in A1. I can sort of see how the codes work and am going to tinker about with it to see if I can expand it. Unfortunately I'm at work again tomorrow but will let you know how I get on by the end of the week. I may need further help as VBA knowledge is pretty basic. Thanks for your assistance so far.

Regards

Colin

 

[colmcg]

Erik,

I named my autoshapes Pos01 to Pos20 and I have now got the following piece of code which works (thankyou very much). However it seems a bit longwinded. Is there a way to shorten this code by looping through each autoshape rather than selecting each one in turn?

CODE:
Sub RankAutoShapes()

'Colours AutoShapes according to Ranking (1 - 20)

Set Sh = ActiveSheet.Shapes("Pos01")
Select Case Range("A1")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos02")
Select Case Range("A2")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos03")
Select Case Range("A3")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos04")
Select Case Range("A4")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos05")
Select Case Range("A05")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos06")
Select Case Range("A6")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos07")
Select Case Range("A7")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos08")
Select Case Range("A8")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos09")
Select Case Range("A9")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos10")
Select Case Range("A10")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos11")
Select Case Range("A11")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos12")
Select Case Range("A12")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos13")
Select Case Range("A13")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos14")
Select Case Range("A14")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos15")
Select Case Range("A15")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos16")
Select Case Range("A16")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos17")
Select Case Range("A17")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos18")
Select Case Range("A18")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos19")
Select Case Range("A19")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
Set Sh = ActiveSheet.Shapes("Pos20")
Select Case Range("A20")
Case 0
Sh.Fill.ForeColor.SchemeColor = 1 'White
Case 1 To 5
Sh.Fill.ForeColor.SchemeColor = 2 'Red
Case 6 To 10
Sh.Fill.ForeColor.SchemeColor = 51 'Orange
Case 11 To 15
Sh.Fill.ForeColor.SchemeColor = 27 'Light Blue
Case 16 To 20
Sh.Fill.ForeColor.SchemeColor = 4 'Blue
End Select
End Sub

 

[erik.van.geit]

I'll take a look at one condition:

The mind of an Excel-lover is full of structure. It loves reading code which is indented: analysing is quicker: so every effort can go to the problem itself...

To let the code stay indented do the following.
Click "reply"
write your message
select your code
click the "Code"-button
(or Click code button, paste your code, click "Code" button again.)
Submit

A real relief for those who try to help you !

WITHOUT
Sub Macro4()
For i = 1 To 3
For j = 1 To 3
m = m & i & j & Chr(10)
Next j
Next i
MsgBox m
End Sub

WITH

Sub Macro4()
    For i = 1 To 3
        For j = 1 To 3
        m = m & i & j & Chr(10)
        Next j
    Next i
MsgBox m
End Sub