Changing colour of autoshapes

C

colmcg

Board Regular
Joined
Jul 2, 2004
Messages
101
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?
 
Sort by date Sort by votes
Erik,

Sorry about that. Hopefully this time the code is attached correctly.

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
 
Upvote 0

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
this looks cool to me :)
Code: 
Option Explicit

Sub RankAutoShapes()

'Colours AutoShapes according to Ranking (1 - 20)

Dim sh As Shape
Dim i As Integer
Dim col As Integer

    For i = 1 To 20
    Set sh = ActiveSheet.Shapes("Pos" & format(i, "00"))
        Select Case Range("A" & i)
        Case 0:         col = 1 'White
        Case 1 To 5:    col = 2 'Red
        Case 6 To 10:   col = 51 'Orange
        Case 11 To 15:  col = 27 'Light Blue
        Case 16 To 20:  col = 4 'Blue
        End Select
    sh.Fill.ForeColor.SchemeColor = col
    Next i

End Sub
 
Upvote 0
You're WELCOME, Colin :)

take your time to understand how it works
you will be able to do this yourself next time
 
Upvote 0
Erik,

Nice job of covering all the bases. Only the tiniest of suggestions -- I would probably use a variable name like intColor or intClr instead of col. In a short procedure like this maybe not an issue. But if this were a longer procedure - especially since you did what I would do and moved the color assignment to the end - there's a good chance one might think col was referring to columns and not colors.

Colin -- this is really a bit nit-picky on my part -- but I have gone back and read code I wrote years and years ago and due to poor variable naming on my part I have found my own code confusing at times. So it's just a tip based on experience - certainly not a criticism of Erik's code.
 
Upvote 0
you're right, Greg, code must be clear

for me it's keeping the balance between good variablenames and readability
my personal style tends to use symbolic names along with an explanatory list

Code: 
Dim CR As Long              'Current Row
Dim TR As Long              'Target Row

that's because I often use formulas like
Code: 
TC = ((CR - FR) Mod (MR * MC)) \ MR + 1
and I prefer to see the mathematical structure in a "condensed way"

as for "col", you're absolutely right, it's an ambiguous variablename

WOW, still "on"topic :LOL:
 
Upvote 0
You may want to look at a solution that puts most of the decisions in the worksheet rather than in code:
Dashboard example – conditional colors of shapes
http://www.tushar-mehta.com/excel/charts/0301-dashboard-conditional shape colors.htm

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?
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
Conditional Formatting
Replies
1
Views
68
trevolly
T
M
  • Question
Conditional formatting specifying 5 colours
Replies
7
Views
542
Peter_SSs
Peter_SSs
T
  • Question
Formulas with Letters and Numbers
Replies
1
Views
114
bobsan42
bobsan42
A
  • Question
VBA to change cell colour based on content
Replies
3
Views
170
Snakehips
Snakehips
O
  • Solved
mod(row() change font colour as required
Replies
7
Views
243
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,215,014
Messages
6,122,697
Members
449,092
Latest member
snoom82

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