Bar Graphs In Cells 2

http://blog.livedoor.jp/andrewe/archives/cat_415504.html

"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!"