There's a couple of ways to go. The first is to adapt the idea behind
Using Worksheet Cells to simulate a graph
http://www.tushar-
mehta.com/excel/newsgroups/worksheet_as_chart/index.htm
While that uses conditional formatting as an example, the concept can
be easily extended to show a bar chart using multiple columns. In
addition to other more obvious benefits, you can even have the bars
change color depending on the value being shown. On the downside,
since the bar size will always be the width of a cell, the visual
representation will move in discrete steps rather than as a smooth
continuous shape.
A more complex alternative using a rectangle shape (from the Drawing
toolbar) would require code. The code below is a crude first-pass
solution. It works but can (should?) be made more robust.
It works by tracking column A values. Each value is expected to be
between 0 and 100. The code adds a rectangle positioned over column B.
The width of the rectangle reflects the value of the number in column
A. All these can be changed in the Worksheet_Change procedure below.
The first part of the code goes in the worksheet module. Note that
this is not something I would do in a 'full fledged' solution. In such
a case, the code would use a class module that included the appropriate
application level event to track changes. But, the below is easier for
demonstration purposes.
On to the code...
In the worksheet's code module:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x As Shape
If Target.Column = 1 Then
Set x = getShape(Target)
x.Width = _
Target.Value / 100 * Target.Offset(0, 1).Width
End If
End Sub
Next, in a standard module:
Option Explicit
Function addShape(aSheet As Worksheet, LocCell As Range) As Shape
Dim x As Shape
Set x = aSheet.Shapes.addShape( _
msoShapeRectangle, 47.25, 13.5, 48.75, 11.25)
With x
.Name = "Rect" & LocCell.Row
.Left = LocCell.Left
.Top = LocCell.Top
.Width = LocCell.Width
.Height = LocCell.Height
With .Fill
.Visible = msoTrue
.Solid
.ForeColor.SchemeColor = 10
.Transparency = 0#
End With
.Line.Visible = msoFalse
End With
Set addShape = x
End Function
Function getShape(Target As Range) As Shape
Dim x As Shape
On Error Resume Next
Set x = Target.Parent.Shapes("rect" & Target.Row)
On Error GoTo 0
If x Is Nothing Then
Set getShape = addShape(Target.Parent, Target.Offset(0, 1))
Else
Set getShape = x
End If
End Function
--
Regards,
Tushar Mehta
www.tushar-mehta.com
Excel, PowerPoint, and VBA add-ins, tutorials
Custom MS Office productivity solutions
