Bar Graphs In Cells 3

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

"Today I was trying to think a way to get around the difference in transparency between Excel versions. This is a possible solution - try something else ;-)

'As you can see I simply adjusted the height - on the left, using a single color, on the right using a gradient with two colors.



'Here's the code with some comments shown to get different effects.

Sub BarGraphsInCells4()
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 ' Adjust width
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveCell.Left, ActiveCell.Offset(1).Top - 1.5, BarWidth, 1.5). _
Select
With Selection
.ShapeRange.Line.Visible = msoFalse ' remove to show lines
.ShapeRange.Fill.ForeColor.SchemeColor = 48 ' change color to suit
.ShapeRange.Fill.BackColor.SchemeColor = 11 'remove for a single color, change color to suit
.ShapeRange.Fill.TwoColorGradient msoGradientVertical, 1 'remove for no gradient
.ShapeRange.Height = 2
.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

'One advantage is you can enter into the cells a lot easier than before. If you want to see the code run automatically, select a range, type a name in the Name Box and push Enter (I've used "MyRange" in this case). Then enter this code in the appropriate sheet under Microsoft Excel Objects in the Visual Basic Editor.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
If Not Intersect(ActiveCell, Range("MyRange")) Is Nothing Then
Shapes("The Bars").Delete
Range("MyRange").Select
BarGraphsInCells4
Target.Select
End If
Application.ScreenUpdating = True
End Sub

Keep in mind calculation may be slowed down somewhat. Use accordingly :-)"