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.
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)
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