Change a shape based on cell value then loop

[MissLady11]

Hi all, new to the site, really new to VBA but this is what I'm trying to do:
In the % Request Responded to column on the attached worksheet, I want to change the shape color based on the percent next to it per the legend at the bottom of the table section.
I only know the long way to do this but would like to loop and not repeat the same code for each group (BSS, OSS, EBI, CBT.....) can someone help me figure out how to set this code up to where I can say for the range of cells in T9-T51, where there is a value, change the shape next to it to red, green or yellow. I have named both the value cell an the shape: below is what I would have to continue for each group if I do this my way....


Private Sub Worksheet_Activate()
If Worksheets("PP Dashboard template").Range("T9").Value < 75 Then
Shapes("BSSAdminDot").Fill.ForeColor.RGB = RGB(192, 0, 0)
ElseIf Worksheets("PP Dashboard template").Range("T9").Value > 75 And Range("T9").Value <= 95 Then
Shapes("BSSAdminDot").Fill.ForeColor.RGB = RGB(203, 108, 29)
ElseIf Worksheets("PP Dashboard template").Range("T9").Value > 95 Then
Shapes("BSSAdminDot").Fill.ForeColor.RGB = RGB(119, 147, 60)
End If


If Worksheets("PP Dashboard template").Range("T12").Value < 75 Then
Shapes("OSSAdminDot").Fill.ForeColor.RGB = RGB(192, 0, 0)
ElseIf Worksheets("PP Dashboard template").Range("T12").Value > 75 And Range("T12").Value <= 95 Then
Shapes("OSSAdminDot").Fill.ForeColor.RGB = RGB(203, 108, 29)
ElseIf Worksheets("PP Dashboard template").Range("T12").Value > 95 Then
Shapes("OSSAdminDot").Fill.ForeColor.RGB = RGB(119, 147, 60)
End If

End Sub

 

[Luke M]

Hi Sylvia,
Rather than try to use VB to make all these colors, which would be quite a pain, why not use the built-in Conditional Formatting? Colored circles is one of the built-in icon sets, and this is MUCH easier to setup, and won't take any run time.

 

[SirJB7]

Hi, MissLady11!

As a new user you might want to (I'd say should and must) read this:
http://chandoo.org/forum/forums/new-users-please-start-here.14/

And regarding your issue, give a look at the uploaded file. There you'll find 2 solutions:

a) For worksheet "PP Dashboard Template (2)", your original one, here's the requested macro:

Option Explicit

Sub PaintingThingsInTheHardWay()
    ' constants
    Const ksWS = "PP Dashboard template (2)"
    Const kiIndex = 6
    Const kiValue = 20
    Const kiRowStart = 9
    Const ksRowEnd = "Legend:"
    Const knLimitHigh = 0.95
    Const knLimitLow = 0.75
    Const ksNameSuffix = "AdminDot"
    ' declarations
    Dim ws As Worksheet
    Dim I As Integer, vValue As Variant, nValue As Single, sIndex As String, lColor As Long
    ' start
    Set ws = Worksheets(ksWS)
    ' process
    With ws
        I = kiRowStart
        Do
            vValue = .Cells(I, kiValue).Value
            If IsError(vValue) Then nValue = 0 Else nValue = vValue
            If nValue > 0 Then
                Select Case nValue
                    Case Is >= knLimitHigh
                        lColor = vbGreen
                    Case Is >= knLimitLow
                        lColor = vbYellow
                    Case Is > 0
                        lColor = vbRed
                End Select
                sIndex = Replace(.Cells(I, kiIndex).Value, " ", "")
                .Shapes(sIndex & ksNameSuffix).Fill.ForeColor.RGB = lColor
            End If
            I = I + 1
        Loop Until CStr(.Cells(I, kiValue).Value) = ksRowEnd
    End With
    ' end
    Set ws = Nothing
    Beep
End Sub

It works fine if you keep the shape names according to column F cell contents plus the suffix "AdminDot" and if "Legend:" is found at bottom of column T.

b) For worksheet "PP Dashboard Template (3)", a copy of the original, with a change in column U:
I set formulas to equal column T values (U9: =T9), and then applied CF conditions with sets of 3 icons according to the thresholds of .95 and .75.

It's up to you to choose which solution you prefer.

Just advise if any issue.

Regards!

 

[MissLady11]

Hi Luke,
I totally agree with you and initially used the conditional formatting option. The managers that get this report didn't like how "flat" the colored circles looked, the closest thing to give the color with more "pop" were the rimmed traffic lights with conditional formatting but of course they didn't want the rim....this was the next best option that I could come up with...... hence the reason why I need the VBA code. Thanks

 

[SirJB7]

The managers that get this report didn't like how "flat" the colored circles looked

@MissLady11
Hi!
What about going to your manager's manager and suggesting him/her to tell to their direct subordinates the three Donald Trump TV show's famous words? "You're fired!"...
Regards!

 

[SirJB7]

Hi, MissLady11!

I just noticed that you posted custom values for red/yellow/green colors, so here's the updated code and the updated file.

Option Explicit

Sub PaintingThingsInTheHardWay()
    ' constants
    Const ksWS = "PP Dashboard template (2)"
    Const kiIndex = 6
    Const kiValue = 20
    Const kiRowStart = 9
    Const ksRowEnd = "Legend:"
    Const knLimitHigh = 0.95
    Const knLimitLow = 0.75
    Const ksNameSuffix = "AdminDot"
    ' declarations
    Dim ws As Worksheet
    Dim I As Integer, vValue As Variant, nValue As Single, sIndex As String, lColor As Long
    Dim lColorRed As Long, lColorYellow As Long, lColorGreen As Long
    ' start
    Set ws = Worksheets(ksWS)
    lColorRed = RGB(192, 0, 0)
    lColorYellow = RGB(203, 108, 29)
    lColorGreen = RGB(119, 147, 60)
    ' process
    With ws
        I = kiRowStart
        Do
            vValue = .Cells(I, kiValue).Value
            If IsError(vValue) Then nValue = 0 Else nValue = vValue
            If nValue > 0 Then
                Select Case nValue
                    Case Is >= knLimitHigh
                        lColor = lColorGreen
                    Case Is >= knLimitLow
                        lColor = lColorYellow
                    Case Is > 0
                        lColor = lColorRed
                End Select
                sIndex = Replace(.Cells(I, kiIndex).Value, " ", "")
                .Shapes(sIndex & ksNameSuffix).Fill.ForeColor.RGB = lColor
            End If
            I = I + 1
        Loop Until CStr(.Cells(I, kiValue).Value) = ksRowEnd
    End With
    ' end
    Set ws = Nothing
    Beep
End Sub

Regards!

PS: BTW, include in the list of future former managers the guy who defined the custom colors!

 

[Debraj]

Here another one..
as you have already done a lot of work, by giving each shape a name..

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 20 Then
        With ActiveSheet.Shapes(WorksheetFunction.Substitute(Range("F" & Target.Row), " ", "") & "AdminDot").Fill.ForeColor
            Select Case Target.Value
                Case Is < 0.75
                    .RGB = RGB(192, 0, 0)
                Case 0.75 To 0.9
                    .RGB = RGB(255, 192, 0)
                Case Is > 0.9
                    .RGB = RGB(53, 139, 86)
            End Select
        End With
    End If
End Sub

 

[MissLady11]

SirJB7 and Debraj both of your codes worked perfectly!!
Thanks a mil for your help.
SirJB7- I would take your advice about the famous words but that might backfire and I get them told to me...lol
Thanks again all, glad I joined this site. Very Helpful!

 

[SirJB7]

Hi, MissLady11!
Glad you solved it. Thanks for your feedback and for your kind words too. And welcome back whenever needed or wanted.
Regards!