In my last post on Excel Sparklines with VBA, I demonstrated:
- Dynamically determine a data range on a worksheet
- Add a Sparkline Group to the next available column
- Format the Sparkline Group for line and Spark Points
- Add the appropriate Axis to each Sparkline Group to be used as a reference to compare actual values to target values
But followers of this blog (both of you) know that I loves me some Pivot Tables! Today, I’ll see if I can create a Pivot Table with Slicers and Sparklines that update as the user is working with the Slicers. For today, I’ll add everything up through Slicers manually and use VBA just for creating the Sparklines.
Create Some Sample Data
First, I’ll need some data. I’d like some QA data for some Reps for each month of 2013. I demonstrated how to create this test data previously using Cartesian Products in MS Access – so I won’t go through all of those steps again. Make sure you check out the link to understand the steps for creating the test data.
- I created a Cartesian Query to join all data from tblDates, tblRegions and tblReps. I added a calculated field to the query to generate sample QAScores.
- I converted the query to a Make Table Query and ran the query thus creating the table: tblSampleData.
- I created a new select query to get all records from the new table.
Connect To Access From Excel
Now that I have a Select Query in the Access Database, I’ll connect to the Query from Excel
- Click on the Data Tab on the Ribbon
- In the Get External Data Group
- Click on “From Access” icon
In the Select Data Source Dialog, navigate to and select the database.
In the Select Table Dialog, choose the Select Query you created in the Access database.
In the Import Data Dialog, accept the defaults to View The Data as a Table in the Workbook and to return the data to $A$1 in the existing worksheet.
The data will be returned from the Access Query to Excel as an Excel Table (a.k.a ListObject Object)
Lastly, I added a Pivot Table and 2 Slicers.
Pivot Table – Replace Data Warning
Recall from my last post, I added Sparklines to the next available blank column adjacent to a Range Object so I need to do the same this time – only I have a Pivot Table that can expand and contract based on Slicer Item selections. This means that if there is anything in the next adjacent column, and the Pivot Table needs to expand, I’ll receive a warning message:
That is not very friendly for the end-user, so I’ll need to figure out a way to handle that.
Clean The Worksheet
I need to begin with a little cleanup on the Worksheet to make sure there is nothing on the Worksheet except for the Pivot Table. The Slicers don’t count since they are Shape Objects that float on a layer above the Worksheet. I also need to unhide any hidden columns:
'Ensure all columns on the worksheet are visible
ws.Cells.Columns.EntireColumn.Hidden = False
'Clear the Worksheet
ClearAllExceptPivotTable pt:=pt
Public Sub ClearAllExceptPivotTable(pt As PivotTable)
'=========================================================================================
'Parameters
'pt Required. A Pivot Table.
'This Sub() clears all cells in the used range of the worksheet except for the Pivot Table
'==========================================================================================
'Declare objects
Dim ws As Worksheet
Dim slg As SparklineGroup
Dim rngPT As Range
Dim rngClear As Range
Dim C As Range
'Error handler
On Error GoTo ErrHandler
'Initialize objects
Set ws = pt.Parent
Set rngPT = pt.TableRange1
'Check each Cell in the used range to determine if the Cell is part of the Pivot Table
'If the Cell is not Part of the Pivot Table, clear the Cell of all contents and formats
For Each C In ws.UsedRange
If Intersect(C, rngPT) Is Nothing Then
If rngClear Is Nothing Then Set rngClear = C Else Set rngClear = Union(C, rngClear)
End If
Next C
If Not rngClear Is Nothing Then rngClear.Clear
'Check if there are any Sparkline Groups on the worksheet - if there are, clear them
'Sometimes these are not included in the UsedRange
ws.Cells.SparklineGroups.Clear
ErrHandler:
If Err.Number > 0 Then _
MsgBox Err.Description, vbMsgBoxHelpButton, "Clear Pivot Table Sparkline Range", Err.HelpFile, Err.HelpContext
'Tidy up
Set C = Nothing
Set rngClear = Nothing
Set rngPT = Nothing
Set ws = Nothing
End Sub
The money shot here is to check if a cell in the TableRange1 of the PivotTable Intersects with the cells of the UsedRange of the Worksheet. If it does intersect, then do nothing, otherwise, clear the cell. The odd part, is that it seems that, at least sometimes, the Sparkline Groups are not included in the UsedRange, so I added the bit to clear any Sparkline Groups.
Handle One Slicer Item
I need to be able to handle the instance where the user might only choose one slicer item for the month. I only want to create a Sparkline if the user selected 2 or more months from the month slicer since a single month is rather meaningless in terms of a Sparkline. So I created a bit of code to get the visible slicer item count and if less than or equal to 1, I’ll return a friendly message to the user and exit the Sub().
'Get the count of the visible slicer items
lngSlicerItemCount = wb.SlicerCaches("Slicer_MonthRecord").VisibleSlicerItems.Count
'If visible slicer count is not greater than 1, then no Sparklines are needed
If lngSlicerItemCount <= 1 Then
MsgBox "There are not enough months of data included in the analysis to generate Sparklines. Exiting"
Exit Sub
End If
Sparkline Group Source Data
One item needed for creating a Sparkline Group, is the source data. For this post, I have a Pivot Table that can expand and contract so the data source will expand and contract based on the slicer items selected by the user. Fortunately, Excel Pivot Tables have Special VBA Range Names. For the data source for the sparklines, I’ll use the DataBodyRange of the Pivot Table.
Check out Jon Peltier’s blog for more on the Special VBA Range Names of Pivot Tables here
'Create a Range Object as the source for the Sparkline Group
Set rngDataBodyRange = pt.DataBodyRange
Does the DataBodyRange Include Grand Totals
If the Grand Totals for Rows is on (True) for the PivotTable, I need to Resize the DataBodyRange by -1 column because I don’t want the Grand Total Column included as part of the data source
'Check if the Range Object needs to be resized due to Grand Total Rows
Set rngSparklineDataSource = GetDataBodyRange(rng:=rngDataBodyRange, _
pt:=pt)
Public Function GetDataBodyRange(pt As PivotTable) As Range
'===============================================================================================
'Parameters
'pt Required. A Pivot Table.
'Returns A Range Object.
'The function returns a Range Object that represents the DataBodyRange of a Pivot Table
'If Grand Totals are displayed, the Range is Resized to exclude the Grand Total Rows
'================================================================================================
'Declare objects
Dim rng As Range
Dim rngFirstCell As Range
Dim rngData As Range
'Declare variables
Dim r As Long
Dim c As Long
'Error handler
On Error GoTo ErrHandler
'Initialize objects
Set rng = pt.DataBodyRange
'Get rows and columns of Pivot Table Range
With rng
r = .Rows.Count
c = .Columns.Count
End With
'Check if Grand Totals are displayed for Rows.
'If they are, decrease the the column count of the Range by 1
With pt
If .RowGrand = True Then c = c - 1
End With
'Create the Data Range without Grand Totals
Set rngFirstCell = rng.Cells(1, 1)
Set rngData = rngFirstCell.Resize(r, c)
'Pass the Range to the Function
Set GetDataBodyRange = rngData
ErrHandler:
If Err.Number > 0 Then _
MsgBox Err.Description, vbMsgBoxHelpButton, "Pivot Table Data Source For Sparklines", Err.HelpFile, Err.HelpContext
'Tidy up
Set rng = Nothing
Set rngFirstCell = Nothing
Set rngData = Nothing
End Function
Where To Put The Sparkline Group
As I stated earlier, in my last post on Sparklines, I was able to position the Sparkline Group immediately adjacent to the Range of data. I cannot do that this time, since the Pivot Table needs room to expand to columns to the right based on which slicer items the user chooses. So I need to place the Sparkline Group somewhere away from the Pivot Table and then hide all empty columns. In the code below< I used an offset of 12 columns from the last column of the DataBodyRange.
'Create a Range Object as the destination for the Sparkline Group
Set rngSparklinePlaceHolder = GetRangeForSparklinePlaceHolder(rng:=rngSparklineDataSource, _
pt:=pt)
Public Function GetRangeForSparklinePlaceHolder(rng As Range, _
pt As PivotTable)
'=========================================================================================
'Parameters
'rng Required. A DataBodyRange of a Pivot Table
'pt Required. A Pivot Table.
'Returns A Range Object.
'The function returns a Range Object which represents a placeholder for a Sparkline Group
'=========================================================================================
'Declare objects
Dim ws As Worksheet
Dim rngSparklineBegin As Range
Dim rngSparklineEnd As Range
Dim rngSparklineTotal As Range
'Error handler
On Error GoTo ErrHandler
'Get Worksheet
Set ws = pt.Parent
'Get first cell and last cell of column adjacent to Pivot Table
'Offset Columns allows Pivot Table to expand without warning of overwriting data
With rng
Set rngSparklineBegin = .End(xlToRight).Offset(0, 12)
Set rngSparklineEnd = .End(xlToRight).End(xlDown).Offset(0, 12)
End With
'Create Range for Sparkline Group
Set rngSparklineTotal = ws.Range(rngSparklineBegin, rngSparklineEnd)
'Pass the Range to the Function
Set GetRangeForSparklinePlaceHolder = rngSparklineTotal
ErrHandler:
If Err.Number > 0 Then _
MsgBox Err.Description, vbMsgBoxHelpButton, "Get Range For Sparkline Group", Err.HelpFile, Err.HelpContext
'Tidy up
Set rngSparklineTotal = Nothing
Set rngSparklineEnd = Nothing
Set rngSparklineBegin = Nothing
Set ws = Nothing
End Function
Plot Variances To Target – Not Actual Values
Recall from my first post on Sparklines with VBA, I went through several machinations to calculate variances to a target value and plotted those variances, not the actual values. This allow me to add a Horizontal Axis as a reference line. Go back and review the first post if you need to review the walk-through of the process.
'Add a worksheet for horizontal axis value calculations
AddWorksheet wb:=wb, _
strSheetName:="SparklineData"
Set wsSparklineData = wb.Worksheets("SparklineData")
'Create a Range on the Sparkline Data Worksheet
'The Range should be the same size as the Source Data Range
With rngSparklineDataSource
lngRowFirstSource = .Row
lngColFirstSource = .Column
lngRowsSource = .Rows.Count
lngColsSource = .Columns.Count
End With
With wsSparklineData
Set rngData = .Cells(lngRowFirstSource, lngColFirstSource)
Set rngData = rngData.Resize(lngRowsSource, lngColsSource)
End With
'Add a formula to the Data Range to determine the difference between Target and Actual
For j = 1 To lngColsSource
For i = 1 To lngRowsSource
rngData.Cells(i, j).Value = rngSparklineDataSource.Cells(i, j).Value - lngTARGET
Next i
Next j
Option Explicit
Public Function AddWorksheet(wb As Workbook, _
strSheetName As String) As Object
'Declare variables
Dim ws As Worksheet
'Error handler
On Error GoTo ErrHandler
'Add worksheet
With wb
On Error Resume Next
.Worksheets(strSheetName).Delete
Set ws = .Sheets.Add(After:=.Sheets(wb.Sheets.Count))
ws.Name = strSheetName
End With
'Pass object to function
Set AddWorksheet = ws
ErrHandler:
If Err.Number > 0 Then _
MsgBox Err.Description, vbMsgBoxHelpButton, "Add a worksheet", Err.HelpFile, Err.HelpContext
'Tidy up
Set ws = Nothing
End Function
Add Sparkline Group
Now that I have a range and a data source, I can add the Sparkline Group:
'Add SparkLine Group
Set slg = GetSparkLineGroup(rngSparklinePlacement:=rngSparklinePlaceHolder, _
rngSparklineSourceData:=rngData)
Option Explicit
Public Function GetSparkLineGroup(rngSparklinePlacement As Range, _
rngSparklineSourceData As Range) As SparklineGroup
'Declare objects
Dim slg As SparklineGroup
'Delare variables
Dim strSourceData As String
'Error handler
On Error GoTo ErrHandler
'Source data address as qualified string
strSourceData = rngSparklineSourceData.Parent.Name & _
"!" & _
rngSparklineSourceData.Address
'Add SparkLine Group
Set slg = rngSparklinePlacement.SparklineGroups.Add(Type:=xlSparkLine, _
SourceData:=strSourceData)
'Pass object to function
Set GetSparkLineGroup = slg
ErrHandler:
If Err.Number > 0 Then _
MsgBox Err.Description, vbMsgBoxHelpButton, "Create SparkLine Group", Err.HelpFile, Err.HelpContext
'Tidy up
Set slg = Nothing
End Function
Format The Sparklines
Now that I have Sparklines, I would like to add a bit of formatting for the line, and the low, high and end spark points:
'Format SparkLine Group
FormatSparkLineGroup slg:=slg, _
lngColorLine:=RGB(128, 128, 128), _
lngColorHighpoint:=RGB(0, 0, 0), _
lngColorLowpoint:=RGB(255, 0, 0), _
lngColorLastPoint:=RGB(0, 0, 0)
Option Explicit
Public Sub FormatSparkLineGroup(slg As SparklineGroup, _
lngColorLine As Long, _
lngColorHighpoint As Long, _
lngColorLowpoint As Long, _
lngColorLastPoint As Long, _
Optional ByVal blnVisHighpoint As Boolean = True, _
Optional ByVal blnVisLowpoint As Boolean = True, _
Optional ByVal blnVisLastpoint As Boolean = True)
'Error handler
On Error GoTo ErrHandler
'Line Settings:
With slg
.LineWeight = 1.3
.SeriesColor.Color = lngColorLine
End With
' High point settings:
With slg.Points.Highpoint
.Visible = blnVisHighpoint
.Color.Color = lngColorHighpoint
End With
' Low point settings:
With slg.Points.Lowpoint
.Visible = blnVisLowpoint
.Color.Color = lngColorLowpoint
End With
' End point settings:
With slg.Points.Lastpoint
.Visible = blnVisLastpoint
.Color.Color = lngColorLastPoint
End With
ErrHandler:
If Err.Number > 0 Then _
MsgBox Err.Description, vbMsgBoxHelpButton, "Format SparkLines", Err.HelpFile, Err.HelpContext
End Sub
Format The Spark Axes
Now I need to format the Sparkline Axes. I need to set the correct scale type for each sparkline based on the count of the values that are greater than or less than 0. All of this has to be dynamic since I don’t know if the user selected 2 months or 12 months or somewhere in-between.
- If all values are less than 0. then the Vertical CustomMinScaleValue is set to 0 and the Horizontal Axis will be a reference line above the Sparkline.
- If all values are greater than 0. then the Vertical CustomMaxScaleValue is set to 0 and the Horizontal Axis will be a reference line below the Sparkline.
- If values are a mix of less than, greater than and equal to 0, then I do not need to specify a scale value and the Horizontal Axis will be a reference line between the SparkPoints.
Option Explicit
Public Sub FormatSparklineAxes(wsReport As Worksheet, _
wsSparklineData As Worksheet, _
rngSparklineSourceData As Range, _
lngValueForComparison As Long, _
lngColorHorizontalAxis As Long, _
Optional ByVal blnVisHorizontalAxis As Boolean = True)
'Declare objects
Dim rngFirstCellSparklineGroup As Range
Dim sg As SparklineGroup
'Declare variables
Dim i As Long 'Loop through data source rows
Dim j As Long 'Loop through data source columns
Dim lngColumnDataSourceBegin As Long 'Column number of beginning of data source
Dim lngColumnDataSourceEnd As Long 'Column number of end of data source
Dim lngColumnsDataSource As Long 'Number of columns in SparkLine Group data source
Dim lngRowSparkLineGroup As Long 'Row number of individual sparkline
Dim lngValueGreater As Long 'Counter - number of values in source greater than target
Dim lngValueLesser As Long 'Counter - number of values in source lesser than target
'Initialize objects and variables
With rngSparklineSourceData
lngColumnDataSourceBegin = .Cells(1, 1).Column
lngColumnDataSourceEnd = .End(xlToRight).Column
End With
lngColumnsDataSource = wsSparklineData.UsedRange.Columns.Count
'Get cell of Sparkline group
Set rngFirstCellSparklineGroup = wsReport.Cells.SparklineGroups.item(1).Location.Cells(1, 1)
'Ungroup Sparkline Group
wsReport.Cells.SparklineGroups.Ungroup
'Determine vertical axis placement for each sparkline
For Each sg In wsReport.Cells.SparklineGroups
i = sg.Location.Row
lngValueLesser = 0
lngValueGreater = 0
For j = lngColumnDataSourceBegin To lngColumnDataSourceEnd
If wsSparklineData.Cells(i, j).Value < lngValueForComparison Then
lngValueLesser = lngValueLesser + 1
ElseIf wsSparklineData.Cells(i, j).Value > lngValueForComparison Then
lngValueGreater = lngValueGreater + 1
Else
'Source data value is equal to target value - axis will plot properly, no action needed
End If
Next j
'Set sparkline axes based on source data values
'If all values are greater than target value, set the Min axis value to zero
'If all values are less than target value, set the Max axis value to zero
With sg.Axes
If lngValueLesser = lngColumnsDataSource Then
.Vertical.MaxScaleType = xlSparkScaleCustom
.Vertical.CustomMaxScaleValue = 0
ElseIf lngValueGreater = lngColumnsDataSource Then
.Vertical.MinScaleType = xlSparkScaleCustom
.Vertical.CustomMinScaleValue = 0
Else
.Vertical.MaxScaleType = xlSparkScaleSingle
End If
.Horizontal.Axis.Visible = blnVisHorizontalAxis
.Horizontal.Axis.Color.Color = lngColorHorizontalAxis
End With
Next sg
' 'Regroup sparklines
' ws.Cells.SparklineGroups.Group Location:=rngFirstCellSparklineGroup
'Tidy up
Set rngFirstCellSparklineGroup = Nothing
End Sub
Add & Format A Header Label For The Sparkline Group
Next, I want to add a header label for the Sparkline Group and format the header so that it has the same format as the header row of the Pivot Table
'Add Sparkline Group Header
rngSparklinePlaceHolder.Cells(1, 1).Offset(-1, 0).Value = "Trend"
'Format Sparkline Group Header
FormatSparklineGroupHeader pt:=pt, _
rng:=rngSparklinePlaceHolder
Public Sub FormatSparklineGroupHeader(pt As PivotTable, _
rng As Range)
'===================================================================================
'Parameters
'pt Required. A Pivot Table.
'rng Required. A Range object that has a header row that needs to be formatted
'Format the header row of a Sparkline Group
'===================================================================================
'Declare objects
Dim rngForFormat As Range
'Error handler
On Error GoTo ErrHandler
'Create Range Object that needs to be formatted
Set rngForFormat = rng.Cells(1, 1).Offset(-2, 0).Resize(2, 1)
'Format the Range
pt.DataBodyRange.End(xlToRight).End(xlUp).Copy
rngForFormat.PasteSpecial _
Paste:=xlPasteFormats, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
ErrHandler:
If Err.Number > 0 Then _
MsgBox Err.Description, vbMsgBoxHelpButton, "Format Sparkline Group Header", Err.HelpFile, Err.HelpContext
'Tidy up
Set rngForFormat = Nothing
End Sub
Add Borders To Sparkline Group Cells
I would like to add cell borders to each cell in the Sparkline Group Range. I think this aids in scanning horizontally from Pivot Table values to the respective Sparkline on each row.
'Add Cell Borders to Sparkline Group
AddRangeBorders rng:=rngSparklinePlaceHolder, _
lngColor:=RGB(217, 217, 217)
Public Sub AddRangeBorders(rng As Range, _
lngColor As Long)
'===============================================================================
'Parameters
'rng Required. A Range Object.
'lngColor Required. Color for Cell Borders.
'This Sub() adds borders to the specified Range Object
'==============================================================================
'Declare objects
Dim c As Range
'Declare variables
'Error handler
On Error GoTo ErrHandler
'Add borders to Range
With rng
.BorderAround LineStyle:=xlContinuous, _
Weight:=xlThin, _
Color:=lngColor
End With
With rng
For Each c In .Cells
With c.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Color = lngColor
.Weight = xlThin
End With
Next c
End With
ErrHandler:
If Err.Number > 0 Then _
MsgBox Err.Description, vbMsgBoxHelpButton, "Add range borders", Err.HelpFile, Err.HelpContext
'Tidy up
End Sub
Hide Empty Columns
Now I would like to hide the empty columns between the Pivot Table and the Sparkline Group so that it appears as though the Sparklines are part of the Pivot Table. This Sub finds the last column of the DataBodyRange and the column of the Sparkline Group and hides everything in-between:
'Hide empty colums between the Pivot Table and the Sparkline Group
HideColumnsBetweenRanges pt:=pt, _
rng:=rngSparklinePlaceHolder
Public Sub HideColumnsBetweenRanges(pt As PivotTable, _
rng As Range)
'=========================================================================================
'Parameters
'pt Required. A Pivot Table.
'rng Required. A Range Object.
'This Sub() hides all colums between a Pivot Table and a related Range Object
'==========================================================================================
'Declare objects
Dim ws As Worksheet
Dim rngHide As Range
'Declare variables
Dim lngColPivotTable As Long
Dim lngColRange As Long
'Error handler
On Error GoTo ErrHandler
'Initialize objects and variables
Set ws = pt.Parent
lngColPivotTable = pt.DataBodyRange.End(xlToRight).Column
lngColRange = rng.Column
'Create a range of columns between the 2 columns
With ws
Set rngHide = .Range(.Cells(1, lngColPivotTable + 1), .Cells(1, lngColRange - 1))
End With
'Hide the range of columns
rngHide.EntireColumn.Hidden = True
ErrHandler:
If Err.Number > 0 Then _
MsgBox Err.Description, vbMsgBoxHelpButton, "Clear Pivot Table Sparkline Range", Err.HelpFile, Err.HelpContext
'Tidy up
Set rngHide = Nothing
Set ws = Nothing
End Sub
Event Driven
The final step, is to wire the Main Procedure to an Event so that as the user clicks on slicer items, all previous data is cleared, the Pivot Table is updated, and new Sparklines are created.
The Worksheet_PivotTableUpdate event is the best event to be used in this case:
Option Explicit
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
'Declare objects
Dim pt As PivotTable
'Excel environment
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'Initialize objects
Set pt = Me.PivotTables(1)
'Clear all Cells on the Worksheet except the Pivot Table
ClearAllExceptPivotTable pt:=pt
'Create Sparklines for Pivot Table
CreateSparkLinesForPivotTable wb:=Me.Parent, _
ws:=Me, _
pt:=Me.PivotTables(1)
'Set focus on the report tab
Me.Activate
Me.Range("C2").Select
'Tidy up
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
The Main Procedure
Here is the main procedure that calls all other Subs() and Functions():
Option Explicit
Public Sub CreateSparkLinesForPivotTable(wb As Workbook, _
ws As Worksheet, _
pt As PivotTable)
'Declare objects
Dim wsSparklineData As Worksheet
Dim rngSparklineGroup As Range
Dim rngDataBodyRange As Range
Dim rngSparklineDataSource As Range
Dim rngSparklinePlaceHolder As Range
Dim rngData As Range
Dim rngHeader As Range
Dim slg As SparklineGroup
'Declare variables
Dim lngSparkLineColumn As Long
Dim lngSparkLineFirstRow As Long
Dim lngSparkLineLastRow As Long
Dim lngRowsSource As Long
Dim lngColsSource As Long
Dim lngRowFirstSource As Long
Dim lngColFirstSource As Long
Dim i As Long
Dim j As Long
Dim lngSlicerItemCount As Long
'Declare constants
Const lngTARGET As Long = 98
Const lngTARGETAXIS As Long = 0
'Error handler
On Error GoTo ErrHandler
'Get the count of the visible slicer items
lngSlicerItemCount = wb.SlicerCaches("Slicer_MonthRecord").VisibleSlicerItems.Count
'Ensure all columns on the worksheet are visible
ws.Cells.Columns.EntireColumn.Hidden = False
'Clear the Worksheet
ClearAllExceptPivotTable pt:=pt
'If visible slicer count is not greater than 1, then no Sparklines are needed
If lngSlicerItemCount <= 1 Then
MsgBox "There are not enough months of data included in the analysis to generate Sparklines. Exiting"
Exit Sub
End If
'Create a Range Object as the source for the Sparkline Group
Set rngDataBodyRange = pt.DataBodyRange
'Check if the Range Object needs to be resized due to Grand Total Rows
Set rngSparklineDataSource = GetDataBodyRange(pt:=pt)
'Create a Range Object as the destination for the Sparkline Group
Set rngSparklinePlaceHolder = GetRangeForSparklinePlaceHolder(rng:=rngSparklineDataSource, _
pt:=pt)
'Add a worksheet for horizontal axis value calculations
AddWorksheet wb:=wb, _
strSheetName:="SparklineData"
Set wsSparklineData = wb.Worksheets("SparklineData")
'Create a Range on the Sparkline Data Worksheet
'The Range should be the same size as the Source Data Range
With rngSparklineDataSource
lngRowFirstSource = .Row
lngColFirstSource = .Column
lngRowsSource = .Rows.Count
lngColsSource = .Columns.Count
End With
With wsSparklineData
Set rngData = .Cells(lngRowFirstSource, lngColFirstSource)
Set rngData = rngData.Resize(lngRowsSource, lngColsSource)
End With
'Add a formula to the Data Range to determine the difference between Target and Actual
For j = 1 To lngColsSource
For i = 1 To lngRowsSource
rngData.Cells(i, j).Value = rngSparklineDataSource.Cells(i, j).Value - lngTARGET
Next i
Next j
'Add SparkLine Group
Set slg = GetSparkLineGroup(rngSparklinePlacement:=rngSparklinePlaceHolder, _
rngSparklineSourceData:=rngData)
'Format SparkLine Group
FormatSparkLineGroup slg:=slg, _
lngColorLine:=RGB(128, 128, 128), _
lngColorHighpoint:=RGB(0, 0, 0), _
lngColorLowpoint:=RGB(255, 0, 0), _
lngColorLastPoint:=RGB(0, 0, 0)
'Format SparkLine Group Axes
FormatSparklineAxes wsReport:=ws, _
wsSparklineData:=wsSparklineData, _
rngSparklineSourceData:=rngData, _
lngValueForComparison:=lngTARGETAXIS, _
lngColorHorizontalAxis:=RGB(128, 128, 128)
'Add Sparkline Group Header
rngSparklinePlaceHolder.Cells(1, 1).Offset(-1, 0).Value = "Trend"
'Format Sparkline Group Header
FormatSparklineGroupHeader pt:=pt, _
rng:=rngSparklinePlaceHolder
'Add Cell Borders to Sparkline Group
AddRangeBorders rng:=rngSparklinePlaceHolder, _
lngColor:=RGB(217, 217, 217)
'Hide empty colums between the Pivot Table and the Sparkline Group
HideColumnsBetweenRanges pt:=pt, _
rng:=rngSparklinePlaceHolder
ErrHandler:
If Err.Number > 0 Then _
MsgBox Err.Description, vbMsgBoxHelpButton, "Create Sparkline Group", Err.HelpFile, Err.HelpContext
Err.Clear
'Tidy up
Set rngSparklineGroup = Nothing
Set rngData = Nothing
Set rngDataBodyRange = Nothing
Set rngSparklineDataSource = Nothing
Set rngSparklinePlaceHolder = Nothing
Set slg = Nothing
Set wsSparklineData = Nothing
With Application
.DisplayAlerts = True
End With
End Sub
Tidy Up
This was a good project, I haven’t seen any posts on Sparklines with Pivot Tables as of yet, so hopefully this is helpful. I’m not a big fan of using the blank columns the way I did and then hiding them. I tried calling the ClearWorksheet Routine first from the PivotTableUpdate Event, but I still received the error warning that I was about to overwrite data on the worksheet. I tried a few other Pivot Table Events, but nothing gave me the right outcome. I think the solution would be for Microsoft to add some Events to Slicer Objects or SlicerItem Objects, such as on Mouse Hover or on SlicerItem_Click.
Downloads
You may download the Excel Workbook, the Access Database and/or the code modules (.bas files) from OneDrive.
- M_CreateSparklinesForPivotTable.bas
- M_ExportModules.bas
- M_FormatSparklineAxes.bas
- M_FormatSparkLines.bas
- M_RangeObject.bas
- M_SparklinesAdd.bas
- M_SparklinesDelete.bas
- M_Worksheet.bas
