Code to change color of shapes

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
19,082
Office Version
2013
Platform
Windows
Hi All
Having a moment.
I modified this code from Snowblizz....but it won't work.
Doesn't error out just runs, with no color changes.
Basically, the comment in cell "F" makes the color of the shape ( Oval) change

I'm missing something simple and it's finally got into my head.....
Any assistance appreciated
Code:
Sub CLChange()
'SnowBlizz
Dim i As Integer, cell As Variant, lr As Long
Dim colourNr As Integer
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Sheet1").Activate
For i = 10 To 32
    Select Case Range("F" & i).Value
    Case "On Target"
            colourNr = 3
    Case "May Need Attention"
            colourNr = 47
    Case "Urgent attention Reqd"
            colourNr = 10
End Select
        With ActiveSheet.Shapes(Range("F" & i).Value)
            .ShapeRange.Fill.ForeColor.SchemeColor = colourNr
        End With
Next i
Application.ScreenUpdating = True
End Sub
 

Some videos you may like

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,616
Hi Michael,

It's failing at the following part:

Code:
With ActiveSheet.Shapes(Range("F" & i).Value)
            .ShapeRange.Fill.ForeColor.SchemeColor = colourNr
        End With
Assuming the the relevant shape name is the same as the value in the cell, try this:

Code:
ActiveSheet.Shapes(Range("F" & i).Value).Fill.ForeColor.SchemeColor = colourNr
HTH

Robert
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
19,082
Office Version
2013
Platform
Windows
Hi Robert
Yep, that fixed it.
I also had a couple of shapes that were formatted as no fill rather than Automatic...which caused them not to work as well
Thanks for the assist.
 

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,105,948
Messages
5,508,316
Members
408,678
Latest member
ripperbolt

This Week's Hot Topics

Top