TopLeftCell change to "bottom"LeftCell

[Guest]

Hello,
I've got a macro (thanks to users here) that inserts a rectangle that fills
a cell proportionally based on the contents of the cell. I would like to
modify it so that the shape starts from the bottom and fills (top to bottom)
proportionally. Here's the macro as it is now:

Sub Proportionally_Fill()

Dim c As Range
Dim v As Single
Dim s As Shape

For Each c In Selection
If c.Value >= 0 And c.Value <= 1 Then

v = c.Value
Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
c.Left, c.Top, c.Width * v, c.Height)
s.Fill.Visible = msoTrue
s.Fill.ForeColor.SchemeColor = 17
s.Line.Visible = msoFalse
Selection.Font.ColorIndex = 2
End If
Next c
End Sub

I can get the overall shape centered, but haven't a clue how to get the
shape to start at the bottom.

Thanks in advance,
MJohn

 

[Tim Williams]

Sub Proportionally_Fill()

Dim c As Range
Dim v As Single
Dim s As Shape
Dim x

For Each c In Selection
If c.Value >= 0 And c.Value <= 1 Then

v = c.Value
x = v * c.Height
Set s = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
c.Left, (c.Top + c.Height) - x, c.Width, x)
s.Fill.Visible = msoTrue
s.Fill.ForeColor.SchemeColor = 17
s.Line.Visible = msoFalse
Selection.Font.ColorIndex = 2
End If
Next c
End Sub

 

[Guest]

Thanks again. You've been a star.

Most appreciated.

MJohn

 

[Tim Williams]

No problem - I will most likely use it myself one day...