In Cell Charting
I discovered a while ago that you can create a Shape from a user-defined function.
This opens the possibility for having custom made graphics dependent on other cells. Meaning, when the data changes, your graphic changes too.
Some possible graphics include line charts, gantt charts, Excel12 style traffic lights.
As an example, I've put together a very basic Sparkline (in-cell line chart) graphic. If you want to know more about Sparklines, start at ewbi.develops
I have a userdefined function named LineChart. It will take a row of values and use them to create a simple linechart within the cell containing the formula.
The formula in cell K1 is =LineChart(A1:J1, 203)
A1:J1 are the data values
203 repesents the colour value for RGB(203, 0, 0)
Finally, the code behind the user-defined function:
Const cMargin = 2
Dim rng As Range, arr() As Variant, i As Long, j As Long, k As Long
Dim dblMin As Double, dblMax As Double, shp As Shape
Set rng = Application.Caller
ShapeDelete rng
For i = 1 To Points.Count
If j = 0 Then
j = i
ElseIf Points(, j)> Points(, i) Then
j = i
End If
If k = 0 Then
k = i
ElseIf Points(, k) <Points(, i) Then
k = i
End If
Next
dblMin = Points(, j)
dblMax = Points(, k)
With rng.Worksheet.Shapes
For i = 0 To Points.Count - 2
Set shp = .AddLine( _
cMargin + rng.Left + (i * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
cMargin + rng.Top + (dblMax - Points(, i + 1)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin), _
cMargin + rng.Left + ((i + 1) * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
cMargin + rng.Top + (dblMax - Points(, i + 2)) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin))
On Error Resume Next
j = 0: j = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(j)
arr(j) = shp.Name
Next
With rng.Worksheet.Shapes.Range(arr)
.Group
If Color> 0 Then .Line.ForeColor.RGB = Color Else .Line.ForeColor.SchemeColor = -Color
End With
End With
LineChart = ""
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
ShapeDelete is an alteration of the ShapeDelete code available on my website
Note that Application.Caller is used to determine which cell is running the formula. That is also used for determining the boundaries of the cell.
One "gotcha" about UDF charts is that you cannot create any shape that writes Text. That can make drawing Legend tables or Value indicators difficult. That said, it's great for drawing graphics.
Jon Peltier:
Hi Rob -
This is way cool. I looked at sparklines a while back after reading one of Tufte's books. My approach was to use a small chart object, the size of the cell, but this was impractical (obviously, or should I say, duh!).
In the meantime I've built one-cell charts using shapes (overlapping rectangles mostly), and I've built shapes in charts to help shade particular regions (http://peltiertech.com/Excel/Charts/VBAdraw.html). But I hadn't thought of putting the two approaches together. And certainly I hadn't thought of a UDF to handle it; I would not have expected it to work.
First I'm going to retool my in-cell bar chart utility (it looks like the Excel 12 conditional formatting, only cooler) to work as a UDF. Then I'm going to play with the sparkline graphics.
Thanks for posting this.
- Jon
5 February 2006, 7:49 pmRob van Gelder:
It was just after writing my wind direction post that I discovered UDF charts.
While writing this comment, I decided to convert Wind Direction to a UDF chart:
(I do hope the code appears correctly in this comment:
Function WindDirectionChart(Degrees As Double) As String
Const cMargin = 2, cPI_180 = 3.14159265358979 / 180
Dim rng As Range, arr() As Variant, shp As Shape
Dim dblX As Double, dblY As Double
Set rng = Application.Caller
ShapeDelete rng
dblX = rng.Left + rng.Width / 2
dblY = rng.Top + rng.Height / 2
Set shp = rng.Worksheet.Shapes.AddLine(dblX, dblY, _
dblX + Cos(Degrees * cPI_180) * (rng.Width / 2 - cMargin), _
dblY + Sin(Degrees * cPI_180) * (rng.Height / 2 - cMargin))
shp.Line.BeginArrowheadStyle = msoArrowheadOval
shp.Line.BeginArrowheadLength = msoArrowheadShort
shp.Line.BeginArrowheadWidth = msoArrowheadNarrow
shp.Line.EndArrowheadStyle = msoArrowheadStealth
WindDirectionChart = ""
5 February 2006, 8:47 pmEnd Function
Tushar Mehta:
I played with "UDF shapes" shortly after a MVP shared the *loophole* in the documented restriction that a UDF cannot change the XL environment. Didn't think of using it for a chart, though. That is a really slick idea. Here's something to think about...
Yes, it is possible to do what you did. However, in addition to being inconsistent with the documentation, it could also be construed as a potential security hole. One could even argue that such loopholes raise questions about the concept of "trustworthy" computing.
Bottom line...one cannot preclude the possibility that MS will get serious about reliable and robust programs and start closing various loopholes in its programs.
A way to implement what you want and remain within the bounds of existing rules is outlined below. A bonus of the below approach is that it *might* improve performance. I used it a year or two ago and it was quite effective.
The UDF should update a data structure with information about what needs to be done -- maybe a UDT that indicates source range, destination range, etc., in a dynamic array (or a collection). Then, check a global date variable and if zero set it to Now() and schedule a procedure with the OnTime method.
Once XL is done recalculating, it will run the scheduled procedure. This procedure can update all the charts (or, in general, all shapes) flagged through the array of the previous paragraph.
I don't know how this will be affected by changes in XL12.
5 February 2006, 9:56 pmAndy Pope:
Hi Rob,
Nice job!
Playing around with this I added a optional argument to the LineChart function to allow plotting of data markers. Using the same technique as your wind direction example.
6 February 2006, 3:29 amStephen Bullen:
Cool technique Rob! Thanks for sharing it with us.
6 February 2006, 5:55 amross:
Well, Stephen is the expert, but I'm kinda with John, i cant really see how the ribbions can be made as customisable as menu's and toolbars - are there still floting toolbars in v12?
And i really dont know how the backwards compat. will work - all custom meuns get stuck in a special bit right - is that the same with custom menu items aswell?
Good news for Dick, key strokes should still work
6 February 2006, 7:02 amross:
SORRY!!!! Worng place!!!
This is very cool Rob, I've seen shapes used to good effect for charts and the like, but wow, with a UDF - i would never have thought that could be done - it's always been - you cant modify with UDF's you cant modify with UDF. Very cool, thanks Rob!!!
6 February 2006, 7:05 amTushar Mehta:
Posted this yesterday but for some reason it still doesn't appear in the comments section...
I played with "UDF shapes" shortly after a MVP shared the *loophole* in the documented restriction that a UDF cannot change the XL environment. Didn't think of using it for a chart, though. That is a really slick idea.
Here's something to think about...Yes, it is possible to do what you did. Of course, in addition to being inconsistent with the documentation, it could also be construed as a potential security hole.
Bottom line...one cannot preclude the possibility that MS will get serious about "trustworthy" computing and start closing various loopholes in its programs.
A way to implement what you want and remain within the bounds of existing rules is outlined below. I used it a year or two ago and it was quite effective.
In the UDF update a data structure with information about what needs to be done -- maybe a UDT that indicates source range, destination range, etc., in a dynamic array (or a collection). Then, check a global date variable and if zero set it to Now() and schedule a procedure with the OnTime method.
Once XL is done recalculating, it will run the scheduled procedure. This procedure can update all the charts (or, in general, all shapes) flagged for revision.
I don't know how the above will be affected by XL12.
6 February 2006, 7:20 amJason Morin:
Rob, this is a great UDF. I could have used this back in my engineering days where I had a million charts that did nothing but clog my worksheets.
By the way, my only comment is that the UDF errors out if all the values are the same. It would nice to see a simple straight line down the middle of the cell.
6 February 2006, 7:54 amDick Kusleika:
Tushar: It got caught in the spam filter, but I still can't tell why.
6 February 2006, 8:05 amDoug Klippert:
I've been looking for something like this since I saw Tufte's article.
The cell can be pasted into Word and serve the purpose of a "Sparkline"
Sparklines: theory and practice
6 February 2006, 9:00 amMichael:
A simplification?
j = 1
6 February 2006, 9:47 amk = 1
For i = 1 To Points.Count
If Points(, j) > Points(, i) Then
j = i
End If
If Points(, k)
Michael:
Looks like it got truncated:
j = 1
6 February 2006, 9:49 amk = 1
For i = 1 To Points.Count
If Points(, j) > Points(, i) Then
j = i
End If
If Points(, k)
Michael:
Problems a bunch. For the 3rd try:
j = 1
6 February 2006, 9:50 amk = 1
For i = 1 To Points.Count
If Points(, j) > Points(, i) Then
j = i
End If
If Points(, k)
Michael:
Giving up after this
6 February 2006, 9:52 amCode ends
If Points(, k)
Andy Pope:
Hi Michael,
You could use this to replace the testing for min max values. And the test for equal values allows for the same value across all points.
dblMin = WorksheetFunction.Min(Points)
dblMax = WorksheetFunction.Max(Points)
If dblMin = dblMax Then
6 February 2006, 10:31 amdblMin = dblMin - 1
dblMax = dblMax + 1
End If
Michael:
Andy -
Thanks. I'm traveling in rarified air when I post here. In general, is it better to "roll you own" VBA function or to use a worksheetfunction call?
WRT my posting problem, I found an old P.S. that probably explains the problem:
"P.S. If you leave a comment with a formula use ampersand-gee-tee-semicolon for greater than and ampersand-ell-tee-semicolon for less than."
Remaining code was similar to what did make it.
Thanks,
6 February 2006, 11:29 amMichael
Dick Kusleika:
Michael: Make sure you're escaping in greater than or less than characters. Or send it to me in an email and I'll try to figure out what's wrong.
6 February 2006, 11:37 amAndy Pope:
Michael,
In general if the built-in function does the job then use it. I'm pretty sure these functions process quicker than any VBA code equivalent.
6 February 2006, 2:14 pmRob van Gelder:
Tushar: I have the same concerns about whether this "feature" will persist in future versions.
Indeed, one could have the UDF append to a job list and have a scheduled task do the drawing.
The effort involved in converting UDF charts to scheduled jobs is minimal, regret low, so personally I'd still be comfortable going UDF... for now...
I dont have XL12 beta to test. I'd be interested to know if it still works.
Michael, Andy: I had plans allowing a user to override min/max, but decided to keep it simple - turned out to be complicated, sorry.
6 February 2006, 2:22 pmAndy - thats a much better way to determine Min/Max.
John Walkenbach:
It doesn't work in Excel 12 Beta 1. Sometimes the little chart appears. Sometimes it produces a BIG chart. But the cell with the formula always returns a #VALUE! error.
It may be related to Beta 1's generally poor screen rendering.
6 February 2006, 5:23 pmAndrew:
Rob,
Very nice
6 February 2006, 8:45 pmSige:
Hi Rob,
I find it very useful!
Would it take much ...?
Is it possible to show a bar graph (clustered column) instead of a line chart?
Cheers Sige
7 February 2006, 3:18 amRob van Gelder:
Sige,
The different would be gaps between bars and a different min/max effect.
I dont think it would be very difficult though (famous last words)....
Let me see what I can put together.
Rob
7 February 2006, 3:29 amRob van Gelder:
Fingers crossed the comment appears correctly:
Function BarChart(Points As Range, Color As Long) As String
Const cMargin = 2, cGap = 1
Dim rng As Range, arr() As Variant, i As Long, j As Long, sng As Double, sngIntv As Single
Dim sngLeft As Single, sngTop As Single, sngWidth As Single, sngHeight As Single
Dim sngMin As Single, sngMax As Single, shp As Shape
Set rng = Application.Caller
ShapeDelete rng
sngMin = WorksheetFunction.Min(Points)
sngMax = WorksheetFunction.Max(Points)
If sngMin > 0 Then sngMin = 0
With rng.Worksheet.Shapes
For i = 0 To Points.Count - 1
sng = Points(, i + 1)
sngIntv = (rng.Height - (cMargin * 2)) / (sngMax - sngMin)
sngLeft = cMargin + cGap + rng.Left + (i * (rng.Width - (cMargin * 2)) / Points.Count)
sngTop = cMargin + rng.Top + (sngMax - IIf(sng < 0, 0, sng)) * sngIntv
sngWidth = (rng.Width - (cMargin * 2)) / Points.Count - (cGap * 2)
sngHeight = Abs(sng) * sngIntv
Set shp = .AddShape(msoShapeRectangle, sngLeft, sngTop, sngWidth, sngHeight)
On Error Resume Next
j = 0: j = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(j)
arr(j) = shp.Name
Next
With rng.Worksheet.Shapes.Range(arr)
.Group
If Color > 0 Then .Fill.ForeColor.RGB = Color Else .Fill.ForeColor.SchemeColor = -Color
End With
End With
BarChart = ""
7 February 2006, 5:00 amEnd Function
Sige:
Hi Rob,
I cannot say much but : SIMPLY F A N T A S T I C !
:o)
7 February 2006, 6:06 amSige
DM Unseen:
To ghet back to Jon's remark.
Here is a general way to mimic Excel 12 Conditional formatting.
Function IConditionalFormat(Target As Range, Optional RefreshShape As Boolean = True, Optional PicType As Long = 0, Optional PicIndex As Long = 0, Optional Color As Long = 0, Optional IconHeight As Double = 1, Optional IconWidth As Double = 0, Optional Margin As Double = 2, Optional Origin As Long = 0) As Long
Dim shp As Shape
Dim sngTop As Single
Dim sngLeft As Single
' UDF Function based on adding shapes to sheet by DM Unseen.
' Inspired by RvGelder's In Cell Charting and Excel 12 extended conditional formatting
' The UDF can be used to mimic in cell icons that react in shape/color to the cell value
' It can also be used to show a bar or any other shape whose size/color needs to be
' linked to formulas
' Note that it is best to stick with one UDF per cell.
' Shapes are always linked to the cell using their name (it will be the cell address)
' Parameters
' Target: Range that gets the picture, usually not the cell this UDF is used in!
' RefreshShape: set to true to delete and add the shape, set to false to only update shape
' PicType set to 0 to delete any shape. Currently only supports autoshapes, but can be
' extended to almost any picture type
' PicIndex: An Icon Index to select the autoshape type
' Color: Only backColor can now be set, but you could extend this to more shape properties.
' Can be an index or an RGB value
' IconHeight/IconWidth: IconHeight and IconWidth are set as a percentage of the cell width/height, 1 being 100%
' Setting Width to 0 will fix it to the height and vice versa
' Margin: Margin can be used to create a margin between cell border and shape
' Origin: The Origin will fix the shape relative to the cell: use numbers 1 to 4 counter clockwise
' for fixing the shape to any of the corners of the cell. Use 5 to center the shape and 0
' to allow free placement across the sheet.
' Worksheet Usage:
' A1=RAND()*100
' A2=RAND()*200
' A3=IConditionalFormat(A2,FALSE,1,A1,IF(A2 0 Then
' calculate icon width/height
If IconHeight 0 Then IconHeight = IconHeight * (Target.Height - Margin * 2)
If IconWidth 0 Then IconWidth = IconWidth * (Target.Width - Margin * 2)
If IconHeight = 0 Then IconHeight = IconWidth
If IconWidth = 0 Then IconWidth = IconHeight
' set origin of the shape
Select Case Origin
Case 1
sngTop = Margin + Target.Top
sngLeft = Margin + Target.Left
Case 2
sngTop = Target.Top + Target.Height - IconHeight - Margin
sngLeft = Margin + Target.Left
Case 3
sngLeft = Target.Left + Target.Width - IconWidth - Margin
sngTop = Margin + Target.Top
Case 4
sngTop = Target.Top + Target.Height - IconHeight - Margin
sngLeft = Target.Left + Target.Width - IconWidth - Margin
Case 5
sngTop = Target.Top + (Target.Height / 2#) - (IconHeight / 2#)
sngLeft = Target.Left + (Target.Width / 2#) - (IconWidth / 2#)
Case 0
If shp Is Nothing Then
sngTop = Margin + Target.Top
sngLeft = Margin + Target.Left
Else
sngTop = shp.Top
sngLeft = shp.Left
End If
Case Else
sngTop = Margin + Target.Top
sngLeft = Margin + Target.Left
End Select
If shp Is Nothing Then
Set shp = Target.Worksheet.Shapes.AddShape(PicIndex, sngLeft, sngTop, IconHeight, IconWidth)
Else
shp.AutoShapeType = PicIndex
End If
With shp
If Color > 0 Then
.Fill.ForeColor.RGB = Color
ElseIf Color IconWidth Then .Width = IconWidth
If .Height IconHeight Then .Height = IconHeight
If .Top sngTop Then .Top = sngTop
If .Left sngLeft Then .Left = sngLeft
.Name = Target.Address
.AlternativeText = Target.Text
End With
Else
shp.Delete
End If
IConditionalFormat = PicIndex
7 February 2006, 9:40 amEnd Function
DM Unseen:
It seems my code has been bitten by the blogbug;)
7 February 2006, 9:54 amTo prevent being accused of 'splogging' with my own code; anyone who wants a working copy, just drop me a mail
Ivan F Moala:
Great stuff ROB!
7 February 2006, 9:14 pmEric W. Bachtal:
Wonderful idea - very nicely done. Can't wait to share it! Oh, and thanks for the link love.
7 February 2006, 11:05 pmRob van Gelder:
Sige (offline) writes...
"I was trying to Add an Average line over the Points."
Can do...
The previous BarChart also had an issue when all points where negative. This one is a little more robust for that.
Function BarChart(Points As Range, Color As Long) As String
Const cMargin = 2, cGap = 1
Dim rng As Range, arr() As Variant, i As Long, j As Long, sng As Single, sngIntv As Single
Dim sngLeft As Single, sngTop As Single, sngWidth As Single, sngHeight As Single
Dim sngMin As Single, sngMax As Single, shp As Shape
Set rng = Application.Caller
ShapeDelete rng
sngMin = WorksheetFunction.Min(Points)
sngMax = WorksheetFunction.Max(Points)
If sngMin > 0 Then sngMin = 0
If sngMax < 0 Then sngMax = 0
With rng.Worksheet.Shapes
For i = 0 To Points.Count - 1
sng = Points(, i + 1)
sngIntv = (rng.Height - (cMargin * 2)) / (sngMax - sngMin)
sngLeft = cMargin + cGap + rng.Left + (i * (rng.Width - (cMargin * 2)) / Points.Count)
sngTop = cMargin + rng.Top + IIf(sng < 0, sngMax, sngMax - sng) * sngIntv
sngWidth = (rng.Width - (cMargin * 2)) / Points.Count - (cGap * 2)
sngHeight = Abs(sng) * sngIntv
Set shp = .AddShape(msoShapeRectangle, sngLeft, sngTop, sngWidth, sngHeight)
On Error Resume Next
j = 0: j = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(j)
arr(j) = shp.Name
Next
sng = (rng.Width - (cMargin * 2)) / Points.Count / 2
sngTop = cMargin + rng.Top + (sngMax - WorksheetFunction.Average(Points)) * sngIntv
Set shp = .AddLine(cMargin + rng.Left + sng, sngTop, rng.Left + rng.Width - cMargin - sng, sngTop)
shp.Line.Weight = 2
On Error Resume Next
j = 0: j = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(j)
arr(j) = shp.Name
With rng.Worksheet.Shapes.Range(arr)
.Group
If Color > 0 Then .Fill.ForeColor.RGB = Color Else .Fill.ForeColor.SchemeColor = -Color
End With
End With
BarChart = ""
7 February 2006, 11:10 pmEnd Function
Sige:
Artwork Rob!
Sooo pleased!!!
Thanks,Thanks
8 February 2006, 3:22 amXL-Dennis:
Rob,
Very nice and highly appreciated.
Thanks for sharing it.
Kind regards,
8 February 2006, 6:23 amDennis
Roger Govier:
Rob,
Thank you so much for sharing this with all of us.
I think it is absolutely marvellous, and I can see some wonderful application for this in another project I am working on right now.
I read these blogs religously, but for some reason never find the time to write.
For this, I just HAD to.
Best Wishes
Roger
8 February 2006, 4:48 pmRobertV:
This is great stuff!
But I must be missing something in the details: I deleted in the original LineChart the following lines of code:
On Error Resume Next
j = 0: j = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(j)
and replaced them with:
ReDim arr(Points.Count - 2)
This line of code is moved outside the For loop and precedes the line
With rng.Worksheet.Shapes
As far as I can observe the function producess the same output. Is there some specific reason for using the On Error / Redim Preserve statements?
PS: With rng.Worksheet.Shapes.Range(arr) (embracing .Group) can be simplified to With .Range(arr)
9 February 2006, 10:50 amRobertV:
Essential line missing in above comment:
Change arr(j)=shp.Name by arr(i)=shp.Name in For Loop
9 February 2006, 11:02 amZolá Simões:
Hi Rob,
Brilliant! Simply Brilliant!
When all cells have the same number, the line function produces an error (#VALUE!)
9 February 2006, 12:36 pmZolá
Rob van Gelder:
RobertV: That section of code is mostly redundant. It's just some code for making an array of Shape Names, which is used to make a ShapeRange, supplied to the .Group method.
Basically, just groups many shapes into one shape.
Good spotting for the With. You're absolutely right - it can be simplified.
If you've ever been tracking my posts / code, you'll notice I often make (what I call) longcuts... opposite of shortcuts.
9 February 2006, 12:52 pmdoco:
I know there must be something blatantly obvious I am missing here, but why doesn't the code work for a verticle list of numbers? You get a chart that looks something like (hoe this works)
*
*
*
*
***********************
of course the asterisks representing line for line chart
|
|
|
| _ _ _ _
and representing the barchart results.
11 February 2006, 8:20 amdoco:
UGH! That didn't work out so well!
11 February 2006, 8:22 amRobertV:
The AddLine statement that draws the line segment was specific to Row oriented data. Following function LineChartMod supports both Line and Column oriented data. It also includes Andy Pope's modification for Min/Max search and draws a line if at least two data points are provided. (original code needs at least three!)
ShpDelete is not modified.
Public Function LineChartMod(Points As Range, Color As Long) As String
'The useable cell area is reduced on all sides by this margin (expressed in points)
Const cMargin = 2
Dim rng As Range, arr() As Variant, i As Long
Dim dblMin As Double, dblMax As Double, shp As Shape
Dim dblYLeftAdjust As Double, dblYRightAdjust As Double
'What is the address of the cell taht called this function?
Set rng = Application.Caller
'If there was already a shape covering this range, then delete it
ShapeDelete rng
'Get Max and Min values of data points, if they are the same then
' readjust (for drawing scale purposes)
dblMin = WorksheetFunction.Min(Points)
dblMax = WorksheetFunction.Max(Points)
If dblMin = dblMax Then
dblMin = dblMin - 1
dblMax = dblMax + 1
End If
'arr is an array that will hold a reference to the line segments
' There are as many segments as there are data points minus one
' (but the array is zero based - hence the -2).
Select Case Points.Count
Case 0, 1
'do nothing - a line needs at least two points
GoTo PROC_EXIT
Case Else
ReDim arr(Points.Count - 2)
End Select
'Draw the individual line segments and add their reference to the array
With rng.Worksheet.Shapes
For i = 0 To Points.Count - 2
If Points.Rows.Count = 1 Then 'Row based data
dblYLeftAdjust = Points(1, i + 1)
dblYRightAdjust = Points(1, i + 2)
ElseIf Points.Columns.Count = 1 Then 'Column based data
dblYLeftAdjust = Points(i + 1, 1)
dblYRightAdjust = Points(i + 2, 1)
End If
Set shp = .AddLine( _
cMargin + rng.Left + (i * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
cMargin + rng.Top + (dblMax - dblYLeftAdjust) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin), _
cMargin + rng.Left + ((i + 1) * (rng.Width - (cMargin * 2)) / (Points.Count - 1)), _
cMargin + rng.Top + (dblMax - dblYRightAdjust) * (rng.Height - (cMargin * 2)) / (dblMax - dblMin))
arr(i) = shp.Name
Next
With .Range(arr)
'Is a ShapeRange object that contains the collection of line segments
' which must be grouped together
Select Case .Count
Case 0, 1
'do nothing - if there are no or only one line segment, you can't group
Case Else
.Group
End Select
If Color > 0 Then .Line.ForeColor.RGB = Color Else .Line.ForeColor.SchemeColor = -Color
End With
End With
PROC_EXIT:
LineChartMod = vbNullString
End Function
12 February 2006, 7:56 amAlex J:
Rob,
Followed the post comments about half-way through - this is cool!
Found something, though:
Once the chart is created, it can be physically moved, but then becomes "disconnected" from the data (I guess because of the mechanism used to create then delete before re-creating)
Would there be a means to connect the graph shape to the originating cell function permanently?
(BTW, this works nicely when you select a range of cells and enter the LineChart or BarChart function as an array formula. I know the idea was to be "in-cell", but "in-cells" works too.)
Also, double-click on the line or bars brings up teh "Format Object Dialog - Any way to preserve setting from this?
14 September 2006, 1:06 pmJon Peltier:
Alex -
I suggested a different machanism for shape deletion in this thread:
http://www.dailydoseofexcel.com/archives/2006/09/13/scaled-in-cell-charting/
Basically you give the shape a unique name that includes the cell name that called it. When it's time to go deleting shapes, even if the shape has moved, it can be found and removed. Of course, if there have been rows and columns incerted and deleted, all bets are off.
15 September 2006, 5:31 amAlex J:
Thanks, Jon.
15 September 2006, 5:53 amI was monitoring that thread, but had not quite understood your intent. Perhaps using named ranges for the cell and its associated chart?
Jon Peltier:
Alex -
I was simply naming the shape that consisted of the group of lines that made up the chart. Normally it would have a name like "Group 12" but I'm giving it a more descriptive name, like "InCell_A1_Line", where A1 is the cell hosting the formula. Instead of killing the shape covering A1, I'm killing the shape with "_A1_" in its name.
Perhaps you've stumbled on a way to get around inserted/deleted rows/columns. When the code runs, give the cell a name (or use its name if one's already defined), something like "CellChartFormula001". Then name the shape "CellChartFormula001_Chart". Then the cell's address doesn't matter, just the cell's name.
This isn't bad, I should write it down. I won't get to it today, because I've had two frantic clients who needed last minute enhancements for today. I shouldn't even be reading this blog.
15 September 2006, 8:49 amAlex J:
Jon,
15 September 2006, 9:05 amStumbled? More like tripped
Frantic clients are the best kind!
Cheers.
Excel Small Visuals « CAM - Blog:
[...] Daily Dose of Excel In-Cell Charting: Check out the Charting category for some other interesting ideas. [...]
20 September 2006, 7:40 pmdave:
First of all, I have to express my appreciation of what you've created here! What a wonderfully simple idea.
And I have a few questions about these sparklines...I've been using the code posted by RobertV on February 12th, 2006 at 7:56 am, the function "LineChartMod".
1. I've been using the sparklines in some spreadsheets to create a dashboard. I have entered the following in several cells:
=LineChartMod(MyRange1,0)
=LineChartMod(MyRange2,0)
... etc
In my code, I update the range names to look at new data. However, this seems to cause a problem, for when I look back at my sheet, there are #Value! errors in the cells, and the lines have not changed.
If I go through these cells and use the F2+Enter trick, they all evaluate fine. Is there a way to force this event on the cells?
2. As a workround to the above problem, I tried entering the strings "=LineChartMod(MyRange1,0)" in the relevant cells from my code, in the hope of forcing evaluation. However, this did not work. It seems that Excel does not evaluate the UDF whilst exectuing my code. Is this normal? Can I do anything about it?
3. I was also trying to extend the funtionality of this UDF by including an additional line (e.g. a line to represent target sales) and be able to have a different colour for this line. I failed miserably to get this to work! Has anyone else had any success?
25 January 2007, 9:13 amJon Peltier:
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
15 February 2007, 7:35 amThush:
This is some really cool stuff that people have done here. I love it!
I have taken the liberty of changing the LineChart function, using a bit of the BarChart function to show a percentile range behind the sparkline. The lower and upper boundaries are passed as parameters to the function. The colour of the percentile range is hard-coded to pale grey, but this could be parameterised if required.
Hope some people may find it useful...
Const cMargin = 2
Dim rng As Range, arr() As Variant, i As Long, j As Long, k As Long
Dim dblMin As Double, dblMax As Double, shp As Shape
Dim rng2 As Range, sng As Double, sngIntv As Single
Dim sngLeft As Single, sngTop As Single, sngWidth As Single, sngHeight As Single
Dim sngMin As Single, sngMax As Single, sngQ1 As Single, sngQ4 As Single
Set rng2 = Application.Caller
ShapeDelete rng2
sngMin = WorksheetFunction.Min(Points)
sngMax = WorksheetFunction.Max(Points)
If sngMin> 0 Then sngMin = 0
sngQ1 = WorksheetFunction.Percentile(Points, Q1)
sngQ4 = WorksheetFunction.Percentile(Points, Q4)
With rng2.Worksheet.Shapes
'Intv = scaling factor
sngIntv = (rng2.Height - (cMargin * 2)) / (sngMax - sngMin)
'Left = starting posn of the bar on the left
sngLeft = cMargin + rng2.Left
'Top = starting posn of the bar on the top
sngTop = cMargin + rng2.Top + ((sngMax - sngQ4) * sngIntv)
'Width = width of the bar
sngWidth = (rng2.Width - (cMargin * 2))
'Height = height of the bar between Q4 and Q1
sngHeight = Abs(sngQ4 - sngQ1) * sngIntv
'Set shp = .AddShape(msoShapeRectangle, sngLeft, sngTop, sngWidth, sngHeight)
With rng2.Worksheet.Shapes.AddShape(msoShapeRectangle, sngLeft, sngTop, sngWidth, sngHeight)
.Fill.ForeColor.RGB = RGB(230, 230, 230)
.Line.DashStyle = msoLineDash
.Line.ForeColor.RGB = RGB(210, 210, 210)
End With
End With
Set rng = Application.Caller
For i = 1 To Points.Count
If j = 0 Then
j = i
ElseIf Points(, j)> Points(, i) Then
j = i
End If
If k = 0 Then
k = i
ElseIf Points(, k) 0 Then .Line.ForeColor.RGB = Color Else .Line.ForeColor.SchemeColor = -Color
End With
End With
LineQChart = ""
End Function
nixnut:
Great stuff here!
Boxplot anyone?
[VB]
Function BoxPlotChart(Maximum As Double, Minimum As Double, Perc25 As Double, Perc50 As Double, Perc75 As Double, EndScale As Double, Optional AcceptableStart As Double = 0, Optional AcceptableEnd As Double = 0, Optional Mean As Double = 0) As String
Const Margin = 0.5
Const Thick = 1.5
Dim rng As Range
Dim arr() As Variant
Dim sng As Single
Dim HBckgrnd As Single
Dim TopBkgrd As Single
Dim StartMin As Single, EndMin As Single
Dim StartMax As Single, EndMax As Single
Dim StartPerc25 As Single, EndPerc25 As Single
Dim StartPerc50 As Single, EndPerc50 As Single
Dim StartPerc75 As Single, EndPerc75 As Single
Dim StartAcceptable As Single, EndAcceptable As Single
Dim StartMean As Single, EndMean As Single
Dim StartMinWhisker, EndMinWhisker
Dim StartMaxWhisker, EndMaxWhisker As Single
Dim TopBox As Single, HeightBox As Single
Dim TopWhiskerLine As Single, HeightWhiskerLine As Single
Dim ShpMinWhiskerEnd As Shape, ShpMinWhiskerLine As Shape
Dim ShpPerc25Box As Shape, ShpPerc50Marker As Shape, ShpPerc75Box As Shape
Dim ShpMaxWhiskerEnd As Shape, ShpMaxWhiskerLine As Shape
Dim ShpAcceptableBar As Shape, ShpMeanMarker 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))
TopBkgrd = rng.Top + (Margin * 2)
TopBox = rng.Top + Margin + rng.Height * 0.17
HeightBox = (rng.Height * 0.66 - Margin * 2)
TopWhiskerLine = rng.Top + Margin + rng.Height * 0.45
HeightWhiskerLine = (rng.Height * 0.15 - Margin * 2)
StartMin = Margin + rng.Left + (WidthCell * (Minimum / EndScale))
EndMin = Margin + rng.Left + (WidthCell * (Minimum / EndScale)) + Thick - StartMin
StartMinWhisker = Margin + rng.Left + (WidthCell * (Minimum / EndScale)) + Thick
EndMinWhisker = Margin + rng.Left + (WidthCell * (Perc25 / EndScale)) - StartMinWhisker
StartPerc25 = Margin + rng.Left + (WidthCell * (Perc25 / EndScale))
EndPerc25 = Margin + rng.Left + (WidthCell * (Perc50 / EndScale)) - StartPerc25
StartPerc50 = Margin + rng.Left + (WidthCell * (Perc50 / EndScale))
EndPerc50 = Margin + rng.Left + (WidthCell * (Perc50 / EndScale)) + Thick - StartPerc50
StartPerc75 = Margin + rng.Left + (WidthCell * (Perc50 / EndScale)) + Thick
EndPerc75 = Margin + rng.Left + (WidthCell * (Perc75 / EndScale)) - StartPerc75
StartMax = Margin + rng.Left + (WidthCell * (Maximum / EndScale))
EndMax = Margin + rng.Left + (WidthCell * (Maximum / EndScale)) + Thick - StartMax
StartMaxWhisker = Margin + rng.Left + (WidthCell * (Perc75 / EndScale))
EndMaxWhisker = Margin + rng.Left + (WidthCell * (Maximum / EndScale)) - StartMaxWhisker
StartAcceptable = Margin + rng.Left + (WidthCell * (AcceptableStart / EndScale))
EndAcceptable = Margin + rng.Left + (WidthCell * (AcceptableEnd / EndScale)) - StartAcceptable
StartMean = Margin + rng.Left + (WidthCell * (Mean / EndScale))
EndMean = Margin + rng.Left + (WidthCell * (Mean / EndScale)) + Thick - StartMean
ReDim arr(1 To 9)
Set ShpAcceptableBar = .AddShape(msoShapeRectangle, StartAcceptable, TopBkgrd, EndAcceptable, HBckgrnd)
16 March 2007, 2:01 amShpAcceptableBar.Line.Visible = msoFalse
If (AcceptableEnd - AcceptableStart
nixnut:
gah, it eats code.
Part 2, continuing after 'If (AcceptableEnd - AcceptableStart':
Else
ShpAcceptableBar.Fill.ForeColor.RGB = 15132390
End If
arr(1) = ShpAcceptableBar.Name
Set ShpMinWhiskerEnd = .AddShape(msoShapeRectangle, StartMin, TopBox, EndMin, HeightBox)
ShpMinWhiskerEnd.Line.Visible = msoFalse
ShpMinWhiskerEnd.Fill.ForeColor.RGB = 11513775
arr(2) = ShpMinWhiskerEnd.Name
Set ShpMinWhiskerLine = .AddShape(msoShapeRectangle, StartMinWhisker, TopWhiskerLine, EndMinWhisker, HeightWhiskerLine)
ShpMinWhiskerLine.Line.Visible = msoFalse
ShpMinWhiskerLine.Fill.ForeColor.RGB = 11513775
arr(3) = ShpMinWhiskerLine.Name
Set ShpPerc25Box = .AddShape(msoShapeRectangle, StartPerc25, TopBox, EndPerc25, HeightBox)
ShpPerc25Box.Line.Visible = msoFalse
ShpPerc25Box.Fill.ForeColor.RGB = 11513775
arr(4) = ShpPerc25Box.Name
Set ShpPerc50Marker = .AddShape(msoShapeRectangle, StartPerc50, TopBox, EndPerc50, HeightBox)
ShpPerc50Marker.Line.Visible = msoFalse
ShpPerc50Marker.Fill.ForeColor.RGB = vbWhite
arr(5) = ShpPerc50Marker.Name
Set ShpPerc75Box = .AddShape(msoShapeRectangle, StartPerc75, TopBox, EndPerc75, HeightBox)
ShpPerc75Box.Line.Visible = msoFalse
ShpPerc75Box.Fill.ForeColor.RGB = 11513775
arr(6) = ShpPerc75Box.Name
Set ShpMaxWhiskerLine = .AddShape(msoShapeRectangle, StartMaxWhisker, TopWhiskerLine, EndMaxWhisker, HeightWhiskerLine)
ShpMaxWhiskerLine.Line.Visible = msoFalse
ShpMaxWhiskerLine.Fill.ForeColor.RGB = 11513775
arr(7) = ShpMaxWhiskerLine.Name
Set ShpMaxWhiskerEnd = .AddShape(msoShapeRectangle, StartMax, TopBox, EndMax, HeightBox)
ShpMaxWhiskerEnd.Line.Visible = msoFalse
ShpMaxWhiskerEnd.Fill.ForeColor.RGB = 11513775
arr(8) = ShpMaxWhiskerEnd.Name
Set ShpMeanMarker = .AddShape(msoShapeRectangle, StartMean, TopBox, EndMean, HeightBox)
ShpMeanMarker.Line.Visible = msoFalse
If (Mean = 0) Then
ShpMeanMarker.Fill.ForeColor.RGB = vbWhite
Else
ShpMeanMarker.Fill.ForeColor.RGB = 203
End If
arr(9) = ShpMeanMarker.Name
rng.Worksheet.Shapes.Range(arr).Group
rng.Worksheet.Shapes(rng.Worksheet.Shapes.Count).Name = _
"InCell_" & rng.Address(False, False) & "_BoxPlotChart"
End With
BoxPlotChart = ""
End Function
Ebar:
Hello,
these functions are very usefull. I'm very interesting to have them but some of them are not written correctly in this blog. Is there another way to catch these function ? (boxplotchart,IConditionalFormat,barchart,...)
Thanks in advance
PS : Sorry for my poor english
11 September 2007, 1:52 amRandy:
I have an add-in whose primary purpose is to pull financial data from the Internet, so I thought some of these in-cell charting techniques would be a nice option to have. But I wanted all of the capabilities in a single function, plus I wanted to add the ability to generate a trend line (the WindDirectionChart gave me that idea). Here's what I have so far:
Optional pType As String = "Line", _
Optional pColor As Long = 203) As String
'-----------------------------------------------------------------------------------------------------------*
' Function to create "in cell" charts -- line charts, bar charts, or slope of linear regression
'-----------------------------------------------------------------------------------------------------------*
' 2007.09.12 -- Adapted from http://www.dailydoseofexcel.com/archives/2006/02/05/in-cell-charting/
' 2007.09.13 -- Change rCaller .Height and .Width attributes to its MergeArea equivalents
' 2007.09.13 -- Add ability to pass a column of data instead of just a row
'-----------------------------------------------------------------------------------------------> Version 2.0g
' Examples of usage:
'
' =smfInCellCharts(A14:I14)
' =smfInCellCharts(A14:I14, "Line", 203)
' =smfInCellCharts(A14:I14, "Bar", 203)
' =smfInCellCharts(A14:I14, "Slope", 203)
'-----------------------------------------------------------------------------------------------------------*
Const cMargin = 2 ' A margin to buffer the usable cell area
Const cGap = 1 ' Size of gap to use between bar charts
Dim rCaller As Range ' The calling range for the function
Dim oRange As Range, oShape As Shape
Dim dMin As Double, dMax As Double
Dim dBegX As Double, dBigY As Double
Dim dEndX As Double, dEndY As Double
smfInCellChart = ""
' Identify the calling range and move the passed data values to an array
Set rCaller = Application.Caller
ReDim vData(1 To pVector.Count)
For i = 1 To pVector.Count
If pVector.Rows.Count = 1 Then vData(i) = pVector(1, i) Else vData(i) = pVector(i, 1)
Next i
'----------------------------------> Delete existing shapes in the calling range
For Each oShape In rCaller.Worksheet.Shapes
Set oRange = Intersect(Range(oShape.TopLeftCell, oShape.BottomRightCell), rCaller.MergeArea)
If Not oRange Is Nothing Then
If oRange.Address = Range(oShape.TopLeftCell, oShape.BottomRightCell).Address Then oShape.Delete
End If
Next oShape
'------------------> Determine type of chart to create
Select Case UCase(pType)
Case "BAR": GoTo Bar_Chart
Case "LINE": GoTo Line_Chart
Case "SLOPE": GoTo Slope_Chart
Case Else
smfInCellCharts = "Incorrect type of chart: " & pType
GoTo ExitFunction
End Select
'------------------> Create a bar chart
Bar_Chart:
Dim sngLeft As Single, sngTop As Single, sngWidth As Single, sngHeight As Single
Dim sngMin As Single, sngMax As Single, shp As Shape
'------------------> Determine minimum and maximum chartable values
dMin = WorksheetFunction.Min(vData)
dMax = WorksheetFunction.Max(vData)
If dMin> 0 Then dMin = 0
If dMin = dMax Then
dMin = dMin - 1
dMax = dMax + 1
End If
'------------------> Draw the bar for each data point
With rCaller.Worksheet.Shapes
For i = 0 To pVector.Count - 1
sngIntv = (rCaller.MergeArea.Height - (cMargin * 2)) / (dMax - dMin)
sngLeft = cMargin + cGap + rCaller.Left + (i * (rCaller.MergeArea.Width - (cMargin * 2)) / pVector.Count)
sngTop = cMargin + rCaller.Top + (dMax - IIf(vData(i + 1) 0 Then .Fill.ForeColor.RGB = pColor Else .Fill.ForeColor.SchemeColor = -pColor
End With
Next i
End With
GoTo ExitFunction
'------------------> Create a line chart
Line_Chart:
'------------------> Determine minimum and maximum chartable values
dMin = WorksheetFunction.Min(vData)
dMax = WorksheetFunction.Max(vData)
If dMin = dMax Then
dMin = dMin - 1
dMax = dMax + 1
End If
'------------------> Draw the lines for each pair of data points
With rCaller.Worksheet.Shapes
For i = 0 To pVector.Count - 2
dBegX = cMargin + rCaller.Left + (i * (rCaller.MergeArea.Width - (cMargin * 2)) / (pVector.Count - 1))
dBegY = cMargin + rCaller.Top + (dMax - vData(i + 1)) * (rCaller.MergeArea.Height - (cMargin * 2)) / (dMax - dMin)
dEndX = cMargin + rCaller.Left + ((i + 1) * (rCaller.MergeArea.Width - (cMargin * 2)) / (pVector.Count - 1))
dEndY = cMargin + rCaller.Top + (dMax - vData(i + 2)) * (rCaller.MergeArea.Height - (cMargin * 2)) / (dMax - dMin)
With .AddLine(dBegX, dBegY, dEndX, dEndY)
If pColor> 0 Then .Line.ForeColor.RGB = pColor Else .Line.ForeColor.SchemeColor = -pColor
End With
Next i
End With
GoTo ExitFunction
'------------------> Create a chart of a linear regression slope line
Slope_Chart:
Dim vTrend() As Variant
'------------------> Create linear regression trend line
vTrend = Application.WorksheetFunction.Trend(vData)
'------------------> Determine minimum and maximum chartable values
dMin = WorksheetFunction.Min(vData, vTrend)
dMax = WorksheetFunction.Max(vData, vTrend)
If dMin = dMax Then
dMin = dMin - 1
dMax = dMax + 1
End If
'------------------> Draw the regression line
With rCaller.Worksheet.Shapes
dBegX = cMargin + rCaller.Left
dBegY = cMargin + rCaller.Top + (dMax - vTrend(1)) * (rCaller.MergeArea.Height - (cMargin * 2)) / (dMax - dMin)
dEndX = rCaller.Left + rCaller.MergeArea.Width - cMargin
dEndY = cMargin + rCaller.Top + (dMax - vTrend(pVector.Count)) * (rCaller.MergeArea.Height - (cMargin * 2)) / (dMax - dMin)
With .AddLine(dBegX, dBegY, dEndX, dEndY)
If pColor> 0 Then .Line.ForeColor.RGB = pColor Else .Line.ForeColor.SchemeColor = -pColor
.Line.BeginArrowheadStyle = msoArrowheadOval
.Line.BeginArrowheadLength = msoArrowheadShort
.Line.BeginArrowheadWidth = msoArrowheadNarrow
.Line.EndArrowheadStyle = msoArrowheadStealth
End With
End With
GoTo ExitFunction
ExitFunction:
End Function
Martin:
Hi Randy,
Your code does not seem to work well.
22 September 2007, 5:33 amI think something is wrong.
Randy:
Below is my current version. I did notice that the prior posting had a few HTML entity substitutions (ampersand, greater than, etc) from the comment editor. One big change was to allow an array to be passed into it instead of just range objects.
Optional pType As String = "Line", _
Optional pColor As Long = 203) As String
'-----------------------------------------------------------------------------------------------------------*
' Function to create "in cell" charts -- line charts, bar charts, or slope of linear regression
'-----------------------------------------------------------------------------------------------------------*
' 2007.09.12 -- Adapted from http://www.dailydoseofexcel.com/archives/2006/02/05/in-cell-charting/
' 2007.09.13 -- Change rCaller .Height and .Width attributes to its MergeArea equivalents
' 2007.09.13 -- Add ability to pass a column of data instead of just a row
'-----------------------------------------------------------------------------------------------> Version 2.0g
' 2007.09.18 -- Fix range/array processing for Trend/Min/Max functions
'-----------------------------------------------------------------------------------------------> Version 2.0h
' Examples of usage:
'
' =smfInCellCharts(A14:I14)
' =smfInCellCharts(A14:I14, "Line", 203)
' =smfInCellCharts(A14:I14, "Bar", 203)
' =smfInCellCharts(A14:I14, "Slope", 203)
'-----------------------------------------------------------------------------------------------------------*
Const cMargin = 2 ' A margin to buffer the usable cell area
Const cGap = 1 ' Size of gap to use between bar charts
Dim rCaller As Range ' The calling range for the function
Dim oRange As Range, oShape As Shape
Dim dMin As Double, dMax As Double
Dim dBegX As Double, dBigY As Double
Dim dEndX As Double, dEndY As Double
Dim iSize As Integer
Dim dHeight As Double, dWidth As Double, dTop As Double, dLeft As Double
smfInCellChart = ""
' Identify the calling range
Set rCaller = Application.Caller
dHeight = rCaller.MergeArea.Height
dWidth = rCaller.MergeArea.Width
dLeft = rCaller.MergeArea.Left
dTop = rCaller.MergeArea.Top
' Handle ranges/arrays and transpose as needed
On Error Resume Next
iSize = UBound(pVector)
iSize = pVector.Count
On Error GoTo 0
ReDim vData(1 To iSize) As Double
i = 0
For Each oItem In pVector
i = i + 1
vData(i) = oItem
Next oItem
'----------------------------------> Delete existing shapes in the calling range
For Each oShape In rCaller.Worksheet.Shapes
Set oRange = Intersect(Range(oShape.TopLeftCell, oShape.BottomRightCell), rCaller.MergeArea)
If Not oRange Is Nothing Then
If oRange.Address = Range(oShape.TopLeftCell, oShape.BottomRightCell).Address Then oShape.Delete
End If
Next oShape
'------------------> Determine type of chart to create
Select Case UCase(pType)
Case "BAR": GoTo Bar_Chart
Case "LINE": GoTo Line_Chart
Case "SLOPE": GoTo Slope_Chart
Case Else
smfInCellCharts = "Incorrect type of chart: " & pType
GoTo ExitFunction
End Select
'------------------> Create a bar chart
Bar_Chart:
Dim sngLeft As Single, sngTop As Single, sngWidth As Single, sngHeight As Single
Dim sngMin As Single, sngMax As Single, shp As Shape
'------------------> Determine minimum and maximum chartable values
dMin = Application.WorksheetFunction.Min(vData)
dMax = Application.WorksheetFunction.Max(vData)
If dMin> 0 Then dMin = 0
If dMin = dMax Then
dMin = dMin - 1
dMax = dMax + 1
End If
'------------------> Draw the bar for each data point
With rCaller.Worksheet.Shapes
For i = 0 To iSize - 1
sngIntv = (dHeight - (cMargin * 2)) / (dMax - dMin)
sngLeft = cMargin + cGap + dLeft + (i * (dWidth - (cMargin * 2)) / iSize)
sngTop = cMargin + dTop + (dMax - IIf(vData(i + 1) 0 Then .Fill.ForeColor.RGB = pColor Else .Fill.ForeColor.SchemeColor = -pColor
End With
Next i
End With
GoTo ExitFunction
'------------------> Create a line chart
Line_Chart:
'------------------> Determine minimum and maximum chartable values
dMin = Application.WorksheetFunction.Min(vData)
dMax = Application.WorksheetFunction.Max(vData)
If dMin = dMax Then
dMin = dMin - 1
dMax = dMax + 1
End If
'------------------> Draw the lines for each pair of data points
With rCaller.Worksheet.Shapes
For i = 0 To iSize - 2
dBegX = cMargin + dLeft + (i * (dWidth - (cMargin * 2)) / (iSize - 1))
dBegY = cMargin + dTop + (dMax - vData(i + 1)) * (dHeight - (cMargin * 2)) / (dMax - dMin)
dEndX = cMargin + dLeft + ((i + 1) * (dWidth - (cMargin * 2)) / (iSize - 1))
dEndY = cMargin + dTop + (dMax - vData(i + 2)) * (dHeight - (cMargin * 2)) / (dMax - dMin)
With .AddLine(dBegX, dBegY, dEndX, dEndY)
If pColor> 0 Then .Line.ForeColor.RGB = pColor Else .Line.ForeColor.SchemeColor = -pColor
End With
Next i
End With
GoTo ExitFunction
'------------------> Create a chart of a linear regression slope line
Slope_Chart:
'------------------> Create linear regression trend line
vTrend = Application.WorksheetFunction.Trend(vData())
'------------------> Determine minimum and maximum chartable values
dMin = Application.WorksheetFunction.Min(vData, vTrend)
dMax = Application.WorksheetFunction.Max(vData, vTrend)
If dMin = dMax Then
dMin = dMin - 1
dMax = dMax + 1
End If
'------------------> Draw the regression line
With rCaller.Worksheet.Shapes
dBegX = cMargin + dLeft
dBegY = cMargin + dTop + (dMax - vTrend(1)) * (dHeight - (cMargin * 2)) / (dMax - dMin)
dEndX = dLeft + dWidth - cMargin
dEndY = cMargin + dTop + (dMax - vTrend(iSize)) * (dHeight - (cMargin * 2)) / (dMax - dMin)
With .AddLine(dBegX, dBegY, dEndX, dEndY)