sparklines in excel 2003

[ChrisExcel]

Goedemiddag,

Al geruime tijd haal ik flink wat informatie van dit forum, maar heb nog nooit zelf een vraag geplaatst, tot nu!

Ik zit met het volgende. Voor het bedrijf waar ik werk is behoefte aan een update van de bestaande tabel waarin de metrics per maand & week worden bij gehouden. De originele maker van de huidige tabel is vertrokken. Nu ben ik zelf nog niet erg thuis in vba etc. dus het is voor mij een behoorlijk uit zoek werk geweest.

Een van de eisen is dat er sparklines in de nieuwe tabel komen voor het kunnen beoordelen vd trend. Echter, er wordt gebruik gemaakt van office 2003. Onderstaand de code die ik kan vinden in VBA.

Mijn vraag is als volgt: Is het mogelijk om op basis hiervan sparklines (zonder invoegtoepassing) te creeren in een nieuw excelbestand (2003). Zo nee, in hoeverre kan ik het bestaande document aanpassen? Alvast hartelijk dank voor de hulp. (bijgevoegd: code sparkline als in vba).

Public Function SparkLine(Points As Range, Color As Long) As String

Application.ScreenUpdating = False

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

SparkLine = ""
Application.ScreenUpdating = True

End Function
Sub ShapeDelete(rngSelect As Range)
Dim shpRng As Range, shp As Shape, blnDelete As Boolean

On Error Resume Next

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

If blnDelete Then shp.Delete
Next
End Sub
Sub DeleteAllShapes()
Dim shp As Shape

For Each shp In Worksheets("Table F").Shapes
shp.Delete
Next
End Sub

 

[Gert Bouwmeeste]

Heb je een voorbeeldbestand?

 

[ChrisExcel]

_{ben er gelukkig al uitgekomen! Hartelijk dank voor eventueel genomen moeite!}