In Cell Charting

Some possible graphics include line charts, 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:


Function LineChart(Points As Range, Color As Long) As String
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) (, 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


You need to insert this code in here:

Tools-->Macro-->Visual Basic Editor
Or Alt + F11

In Project: Right Click & Insert--> Module

And past the above codes and Enjoy.


No comments:

Post a Comment

Bookmark and Share