VBA formatting a shape

[Pavertheway]

Hi,

I have percentage values in certain cells on a sheet (E3 currently displays 84% for example). I would like a shape which takes the value of E3, and then applies that percentage to a gradient fill level of the shape, starting at the bottom.

So if the shape (an Oval), was to take 50%, then the bottom half of it would be blue, and the top half empty.

Is this possible to do in VBA? I know I can use conditional formatting to match 50% to a specific colour, but I don't think conditional formatting can be used to apply to a gradient fill (as far as I know, I am very willing to be proved wrong!)

Any help would be greatly appreciated.

Thank you!

 

[Yongle]

Rectangle 1 is based on A1, Rectangle 2 is based on B2

I think you mean Rectangle 1 is based on A1, Rectangle 2 on B1
If you want A1, B2, C3, D4 ... then

Prop = 1 - Cells([COLOR=#ff0000]c[/COLOR], [COLOR=#ff0000]c[/COLOR])

If you want A1, B1, C1, D1 ... then

Prop = 1 - Cells([COLOR=#ff0000]c[/COLOR], 1[COLOR=#ff0000][/COLOR])

Try a loop like this (untested)
- On Error Resume Next included to prevent code failing if a shape not found
- Range("A1").Select is included to deselect each shape (prevents wrong shape being selected of a shape is not found)

Sub GradShape()
    Dim Prop As Double, c As Long
    For [COLOR=#ff0000]c[/COLOR] = 1 To 9
        On Error Resume Next
        Prop = 1 - ActiveSheet.Cells(1, [COLOR=#ff0000]c[/COLOR]).Value
        ActiveSheet.Shapes("Rectangle " & c).Select
        With Selection.ShapeRange.Fill
            .GradientStops(3).Position = 1
            .GradientStops(2).Position = Prop
            .GradientStops(1).Position = Prop
        End With
        Range("A1").Select
    Next [COLOR=#ff0000]c[/COLOR]
End Sub

 

[Yongle]

Oops - a typo!
Instead of
If you want A1, B1, C1, D1 ... then
I meant to write
If you want A1, A2, A3, A4 ... then

 

[Pavertheway]

Hi,

The loop you posted that you said was untested works like a charm. Thank you so so much! If the values (A1, B1, C1, etc) were in sequential cells (E3, G3, I3, K3, M3, O3, Q3) how would this work?
Sorry to be a pain - I am just trying to understand how your code works - haha!
Thank you again for your time

 

[Yongle]

try this
- it is now becomes simpler to use one variable for shape name (s) and another cell column reference (c)

- the first cell is E3 [ Cells(3, 5) ]
- and the column increases by 2 [ hence Step 2 ]
- until it gets to Q3 [= cells(3, 17) ]
- which is 7 iterations [ (17 - 5 ) /2 + 1 ]
- variable s values increases by 1 with each iteration (ie from 1 to 7)

Sub GradShape()
    Dim Prop As Double, c As Long, [COLOR=#ff0000]s[/COLOR] As Long
    For[COLOR=#006400] c = 5 To 17 Step 2[/COLOR]
        On Error Resume Next
        [COLOR=#ff0000]s[/COLOR] = s + 1
        Prop = 1 - ActiveSheet.Cells([COLOR=#006400]3[/COLOR], [COLOR=#006400]c[/COLOR]).Value
        ActiveSheet.Shapes("Rectangle " & [COLOR=#ff0000]s[/COLOR]).Select
        With Selection.ShapeRange.Fill
            .GradientStops(3).Position = 1
            .GradientStops(2).Position = Prop
            .GradientStops(1).Position = Prop
        End With
        Range("A1").Select
    Next c
End Sub

 

[Yongle]

And for completeness... in case you are wondering what to do if the cells are not in some kind of evenly spaced sequence and/or the names do not increment by one (in example below both are irregular)

one way would be to use arrays
each array has the same number of items
result written to message box

Sub UsingArrays()
    Dim arr1, arr2, a, msg As String
    arr1 = Split("E3 F3 G3 M3 N3 O3 P3", " ")
    arr2 = Split("10 2 13 4 5 6 7", " ")
    For a = 0 To UBound(arr1)
        msg = msg & vbCr & ActiveSheet.Range(arr1(a)).Address(0, 0) & vbTab & "Rectangle " & arr2(a)
    Next a
    MsgBox msg
End Sub

 

[Pavertheway]

These work absolutely perfectly. Thank you so much for taking the time to help me and walk through exactly how it needed to be done, and what each step means!

 

[Yongle]

You are welcome
Thanks for the feedback

 

[Pavertheway]

Hi,
Sorry to bother you one last time - I have taken the code you provided from my test workbook as you suggested earlier and placed it in my actual workbook and it works perfectly, I've adjusted colours etc and its brilliant, so thank you.
The only thing is in the cells E3, G3, etc is a formula (='Sheet4'!AF2) and I would like the macro to run automatically when this sheet is updated. I have used Worksheet_Change before, but I believe this would use Worksheet_Calculate. How would I attach Worksheet_Calculate to the macro you provided?

 

[Yongle]

try

Private Sub Worksheet_Calculate()
    Call GradShape
End Sub

 

[Pavertheway]

I tried that in project ThisWorkbook and the sheet itself and neither worked (but did not produce any debug error, it just didn't fire the Macro)