Bar Graphs In Cells

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

"I just saw a future conditional format coming up in Excel 12 via the J-Walk Blog and thought I would try to imitate it. Note: This should work fine with Excel 2002 and 2003, I'm not sure about earlier versions but you can give it a try. (The transparency feature might not work as well though)

'Here's the real McCoy... (picture from David Gainer's Microsoft Excel blog)



'And here's the code I used with Autoshapes...

Sub BarGraphsInCells()
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.7 ' Adjust to suit
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Top, BarWidth, ActiveCell.Height). _
Select
With Selection
.ShapeRange.Fill.ForeColor.SchemeColor = 12
.ShapeRange.Line.Visible = msoFalse
.ShapeRange.Fill.Transparency = 0.8
.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

'And the result...



Hmm, not too bad considering it's way past my bedtime. Night!"