October 06, 2005

Bar Graphs In Cells 2

Continuing from my last post - I had a little spare time today so I decided to experiment a little more with the appearance. Here's my improved code to get the same kind of gradient effect as shown below (rather than just transparency)

Sub BarGraphsInCells2()
    On Error Resume Next
    Dim LoopCount As Long, BarWidth As Long, Cell As Range, theRange As Range
    Set theRange = Selection
    LoopCount = 1
    For Each Cell In theRange
        BarWidth = (ActiveCell.Value / Application.Max(theRange)) * ActiveCell.Width * 0.9
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, BarWidth, ActiveCell.Height). _
            Select
        With Selection
            .ShapeRange.Line.Visible = msoFalse
            .ShapeRange.Fill.Transparency = 0.8
            .ShapeRange.Fill.ForeColor.SchemeColor = 48
            .ShapeRange.Fill.OneColorGradient msoGradientVertical, 2, 0.5
            .Name = "The Bars" & LoopCount
        End With
        ActiveSheet.Shapes.Range(Array("The Bars", "The Bars" & LoopCount)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "The Bars"
        Cell.Offset(1).Select
        LoopCount = LoopCount + 1
    Next
    theRange.Select
End Sub

This seems to be getting close.



The next trick was to add a little extra in the way of conditioning. I used CBool to get a TRUE condition, otherwise skip the part where AutoShapes are added, then go to the next step, which I very orginally named "NextStep" :-)

Here's an example that looks for the 5 highest values using RANK (be warned that this works a little strange in the case of duplicates).

Sub BarGraphsInCells3()
    On Error Resume Next
    Dim LoopCount As Long, BarWidth As Long, Cell As Range, theRange As Range
    Set theRange = Selection
    LoopCount = 1
    For Each Cell In theRange
    If Not CBool(Application.Rank(Cell, theRange) <= 5) Then GoTo NextStep
        BarWidth = (ActiveCell.Value / Application.Max(theRange)) * ActiveCell.Width * 0.9
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, BarWidth, ActiveCell.Height). _
            Select
        With Selection
            .ShapeRange.Line.Visible = msoFalse
            .ShapeRange.Fill.Transparency = 0.8
            .ShapeRange.Fill.ForeColor.SchemeColor = 10 'change the color here!
            .ShapeRange.Fill.OneColorGradient msoGradientVertical, 2, 0.5
            .Name = "The Bars" & LoopCount
        End With
NextStep:
        ActiveSheet.Shapes.Range(Array("The Bars", "The Bars" & LoopCount)).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = "The Bars"
        Cell.Offset(1).Select
        LoopCount = LoopCount + 1
    Next
    theRange.Select
End Sub

If you wanted to run the code without any extra conditions, just place an apostrophe in front of the CBool line to "deactivate" it (making it a comment instead of working code)

Okay, let's take it a step further...first run the code to include all cells with a .ShapeRange.Fill.ForeColor.SchemeColor property of 10, then go to the Name Box and enter a new name for the grouped AutoShapes (eg "All The Bars") and push Enter. Then run the code again using a different SchemeColor (48) and use CBool to find the top 5 values as above. Enter a new name, say "The Top 5 Bars". Then let's try it again changing the CBool part to select all all values equal to or over 20 with a SchemeColor of 11. Rename to suit, "All Bars Over 20". (This renaming part is real hard work)

If obscured, right click the last group and select Order, Send Backward. You should end up with something like this.



Not bad for a hack (the code, not me) but as has been mentioned in my former post, not nearly as good as built-in Conditional Formatting where the colors change automatically (no code necessary). Then again the you can keep the grouped AutoShapes as "hardcopies", writing the condition may be a little simpler too depending on what you are trying to achieve. Then again, this is just one imitation format, I can only wait in anticipation to see what kind of tricks can be performed with Excel 12 ;-)

PS. Thanks Rembo for letting me know about the different row heights!

Write a Comment
Hi Andrew,

Excel-lent code! I just dropped you an email concerning the row height. I see an overlap of the 'bars'which makes it a little messy to look at. (default row height is 12.75, in your code it's fixed to 14.25)

Replacing the 14.25 with ActiveCell.Height automatically uses the current row height and thus fixes the problem.

Rembo
Posted by Rembo at October 06, 2005 20:41
Thanks for letting me know Rembo, I was not aware of differing row heights! Anyway, your kind suggestion of using ActiveCell.Height seems to do the trick ;-)
Posted by Andrew at October 06, 2005 21:16
Hi Andrew,

For some reason all my excel documents have altered. When I type in a cell and hit the enter space- I used to move to the next cell. Now it moves the page across instead. I have to physically hit the next cell with the mouse to move the cursor into that cell. Do you know how to fix that and/or what I have done to change it to this mode (so I know not to do it again)

Thanks.
Kim
Posted by Kim Gibson at February 22, 2006 14:31
Hi Kim,

Go to Tools, Options, Edit, you should see a checkbox marked "Move selection after Enter". Make sure the Direction is "Down"
Posted by Andrew at March 01, 2006 22:13