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