Comments on: Scaled In Cell Charting

By: Jon Peltier

Jon Peltier — Thu, 15 Feb 2007 14:38:00 +0000

Here's an outstanding rendition of sparklines by Excel MVP Fernando Cinquegrani:

http://www.prodomosua.eu/zips/sparklines.xls

He draws a normal-sized and normal-featured Excel chart in a far away region of the sheet, copies the underlying range, and uses Paste Link Picture to put a dynamic shrunken image of the chart over the desired cell.

It will fail in 2007 because doing a print preview of a paste linked region that shows a chart hoses the chart. But in versions up to 2003, it is an excellent native sparklines tool. The rest of us can stop now.

Fernando has come up with dozens of innovative display implementations for Excel:

http://www.prodomosua.eu/ppage02.html

(also posted in this thread: http://www.dailydoseofexcel.com/archives/2006/02/05/in-cell-charting/)

By: Jon Peltier

Jon Peltier — Thu, 21 Dec 2006 14:03:00 +0000

You don’t want to oversimplify this deletion routine. What if the user accidentally dragged a shape off of its original location? What if a different but important shape happens to be located in the range being cleared? These are why labeling is important. In fact, in one of my iterations (which I may not have posted), the shape name includes the name of the cell it is supposed to cover. The code checkes this name, not the actual top left cell, prior to deletion.

By: Mr Israel Steinmetz

Mr Israel Steinmetz — Wed, 20 Dec 2006 19:23:00 +0000

Come to think of it, in the first post, the whole complex ShapeDelete procedure can be replaced with:

Sub ShapeDelete(rngSelect As Range)
Dim shp As Shape

For Each shp In rngSelect.Worksheet.Shapes
If rngSelect.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then shp.Delete
Next
End Sub

The original (complex) procedure first looks for all shapes intersecting rngSelect, then verifies that they are completely contained in rngSelect, then sets a boolean flag, and finally deletes the shape if flagged. Instead, just delete any shape that is contained in rngSelect. Much simpler, and does the same thing.

By: Mr Israel Steinmetz

Mr Israel Steinmetz — Tue, 12 Dec 2006 18:36:00 +0000

Oops. I meant, replace it with:

If VerticalScale Is Nothing Then
Set rScale = Points
Else
Set rScale = Application.Union(Points, VerticalScale)
End If

All of the other conditions are meaningless, they come out to the same thing as a simple Union.

By: Mr Israel Steinmetz

Mr Israel Steinmetz — Tue, 12 Dec 2006 17:54:00 +0000

I think it would make sense to replace:

If VerticalScale Is Nothing Then
Set rScale = Points
Else
If Not Application.Intersect(Points, VerticalScale) Is Nothing Then
If Application.Intersect(Points, VerticalScale).Address = _
Points.Address Then

Set rScale = VerticalScale
Else
Set rScale = Application.Union(Points, VerticalScale)
End If
Else
Set rScale = Application.Union(Points, VerticalScale)
End If
End If

with:

Set rScale = Application.Union(Points, VerticalScale)

By: Fabrice Rimlinger

Fabrice Rimlinger — Sun, 26 Nov 2006 19:47:00 +0000

Bonjour,

here is a modest contribution to this post that helped me so much.
another tool on the "in cell" chartind UDF subject, the bullet chart as explained here : http://www.exceluser.com/explore/bullet.htm

Thanks to all contributors...

Function BulletChart(Mesure As Double, Target As Double, Maxi As Double, Optional Good As Double, Optional Bad As Double) As String
Const Margin = 2
Const Thick = 1.5
Dim rng As Range
Dim arr() As Variant
Dim sng As Single, RapTM As Single
Dim HBckgrnd As Single, HMesure As Single, HTarget As Single
Dim TopBkgrd As Single, TopMesure As Single, TopTarget As Single
Dim StrtMesure As Single, StrtTarget As Single, StrtGood As Single, StrtAverage As Single, StrtBad As Single
Dim EndBckgrd As Single, EndMesure As Single, EndTarget As Single, EndBad As Single, EndGood As Single, EndAverage As Single
Dim ShpBad As Shape, ShpGood As Shape, ShpAverage As Shape, ShpTarget As Shape, ShpMesure As Shape
Dim WidthCell As Single

Set rng = Application.Caller
ShapeDelete rng

With rng.Worksheet.Shapes
WidthCell = rng.MergeArea.Width
HBckgrnd = (rng.Height - (Margin * 2))
HMesure = (rng.Height * 0.5 - Margin * 2)
HTarget = (rng.Height * 0.9 - Margin * 2)
TopBkgrd = rng.Top + Margin
TopMesure = rng.Top + Margin + rng.Height * 0.25
TopTarget = rng.Top + Margin + rng.Height * 0.05
StrtMesure = Margin + rng.Left
StrtTarget = Margin + rng.Left + (WidthCell * (Target / Maxi))
StrtGood = StrtMesure
StrtAverage = Margin + rng.Left + (WidthCell * (Good / Maxi))
StrtBad = Margin + rng.Left + (WidthCell * (Bad / Maxi))
EndBad = rng.Left + WidthCell - (Margin) - StrtBad
EndGood = rng.Left + WidthCell - (Margin) - StrtGood
EndAverage = rng.Left + WidthCell - (Margin) - StrtAverage
EndMesure = Margin + rng.Left + (WidthCell * (Mesure / Maxi)) - StrtMesure
EndTarget = Margin + rng.Left + (WidthCell * (Target / Maxi)) + Thick - StrtTarget

ReDim arr(1 To 5)

Set ShpGood = .AddShape(msoShapeRectangle, StrtGood, TopBkgrd, EndGood, HBckgrnd)
ShpGood.Line.Visible = msoFalse
ShpGood.Fill.ForeColor.RGB = 11513775
arr(1) = ShpGood.Name

Set ShpBad = .AddShape(msoShapeRectangle, StrtBad, TopBkgrd, EndBad, HBckgrnd)
ShpBad.Line.Visible = msoFalse
ShpBad.Fill.ForeColor.RGB = 13158600
arr(2) = ShpBad.Name

Set ShpAverage = .AddShape(msoShapeRectangle, StrtAverage, TopBkgrd, EndAverage, HBckgrnd)
ShpAverage.Line.Visible = msoFalse
ShpAverage.Fill.ForeColor.RGB = 15132390
arr(3) = ShpAverage.Name

Set ShpMesure = .AddShape(msoShapeRectangle, StrtMesure, TopMesure, EndMesure, HMesure)
ShpMesure.Line.Visible = msoFalse
ShpMesure.Fill.ForeColor.RGB = 0
arr(4) = ShpMesure.Name

Set ShpTarget = .AddShape(msoShapeRectangle, StrtTarget, TopTarget, EndTarget, HTarget)
ShpTarget.Line.Visible = msoFalse
ShpTarget.Fill.ForeColor.RGB = 203
arr(5) = ShpTarget.Name

rng.Worksheet.Shapes.Range(arr).Group

End With

BulletChart = ""
End Function

Sub ShapeDelete(rngSelect As Range)
Dim rng As Range, shp As Shape, blnDelete As Boolean

For Each shp In rngSelect.Worksheet.Shapes
blnDelete = False
Set rng = Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rngSelect)
If Not rng Is Nothing Then
If rng.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then blnDelete = True
End If

If blnDelete Then shp.Delete
Next
End Sub

By: Fabrice Rimlinger

Fabrice Rimlinger — Sun, 26 Nov 2006 19:46:00 +0000

Bonjour,

here is a modest contribution to this post that helped me so much.
another tool on the "in cell" chartind UDF subject, the bullet chart as explained here : http://www.exceluser.com/explore/bullet.htm

Thaks to a

Set rng = Application.Caller
ShapeDelete rng

ReDim arr(1 To 5)

Set ShpGood = .AddShape(msoShapeRectangle, StrtGood, TopBkgrd, EndGood, HBckgrnd)
ShpGood.Line.Visible = msoFalse
ShpGood.Fill.ForeColor.RGB = 11513775
arr(1) = ShpGood.Name

Set ShpBad = .AddShape(msoShapeRectangle, StrtBad, TopBkgrd, EndBad, HBckgrnd)
ShpBad.Line.Visible = msoFalse
ShpBad.Fill.ForeColor.RGB = 13158600
arr(2) = ShpBad.Name

Set ShpAverage = .AddShape(msoShapeRectangle, StrtAverage, TopBkgrd, EndAverage, HBckgrnd)
ShpAverage.Line.Visible = msoFalse
ShpAverage.Fill.ForeColor.RGB = 15132390
arr(3) = ShpAverage.Name

Set ShpMesure = .AddShape(msoShapeRectangle, StrtMesure, TopMesure, EndMesure, HMesure)
ShpMesure.Line.Visible = msoFalse
ShpMesure.Fill.ForeColor.RGB = 0
arr(4) = ShpMesure.Name

Set ShpTarget = .AddShape(msoShapeRectangle, StrtTarget, TopTarget, EndTarget, HTarget)
ShpTarget.Line.Visible = msoFalse
ShpTarget.Fill.ForeColor.RGB = 203
arr(5) = ShpTarget.Name

rng.Worksheet.Shapes.Range(arr).Group

End With

BulletChart = ""
End Function

Sub ShapeDelete(rngSelect As Range)
Dim rng As Range, shp As Shape, blnDelete As Boolean

If blnDelete Then shp.Delete
Next
End Sub

By: Jon Peltier

Jon Peltier — Sun, 17 Sep 2006 13:46:00 +0000

Hmmm, didn’t try that. Not moving the shapes, I doubt that’s the issue. I think Excel just needs the short break that moving the shapes provides. I’ll try using DoEvents, probably after each shape is made and after each is deleted.

By: Kevin Fitting

Kevin Fitting — Sat, 16 Sep 2006 23:03:00 +0000

Don't know if this will help the excel crashing, but before you delete a shape, move it to with in the cell border. I've been working on putting labels at specific points along the line. If those labels protrude into adjacent cells, excel crashes when it tries to delete them (not while stepping through though... annoying!). Solution was to move each label to the left top edge of the cell, then delete. I'll probably shrink it's width to handle small cells, but it seems to work. I wonder if this were applied to the line itself Excel wouldn't crash. I don't know.

Kevin

By: Kevin Fitting

Kevin Fitting — Sat, 16 Sep 2006 18:42:00 +0000

Got it. Change the lines for width and height to this:
dEffWidth = rCaller.MergeArea.Width - (lMARGIN * 2)
dEffHeight = rCaller.MergeArea.Height - (lMARGIN * 2)

Now it will put the line across a merged cell. Next, I'm going to try to get it to draw a vertical line for vertical data. Shouldn't be too hard... (famous last words!)

Kevin