SparklineHeader3

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.

As the user clicks on slicer items, the old Sparklines are deleted and new Sparklines are created
.


 

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.

QASparklineData2

  1. 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.
  2. I converted the query to a Make Table Query and ran the query thus creating the table: tblSampleData.
  3. 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

ConnectToAccess

  1. Click on the Data Tab on the Ribbon
  2. In the Get External Data Group
  3. Click on “From Access” icon

NavigateToDatabase

In the Select Data Source Dialog, navigate to and select the database.

AccessSelectQuery

In the Select Table Dialog, choose the Select Query you created in the Access database.

ImportDataDialog

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.

DataImportExcelAccess

The data will be returned from the Access Query to Excel as an Excel Table (a.k.a ListObject Object)

InitialPivotWithSlicers

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:

DataReplaceDialog

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

NotEnoughData

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

SLGAdded3

The Sparkline Group has been added. Note the 11 blank columns.


 

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

SLGFormatted2

The Sparklines have been formatted for line weight, line color, spark markers: low, high, end points
.


 

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

SLGAxesFormatted

The Sparkline Axes have been formatted for visibility, line color and scale type
.


 

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

SLGHeader

A label has been added to the row above the Sparkline Group and it has been formatted the same as the header row of the Pivot Table
.


 

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

SLGBorders

Thin light borders have been added to each Cell in the Sparkline Group
.


 

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

SLGHiddenColumns

All columns between the DataBodyRange of the Pivot Table and the Sparkline Group have been hidden
.


 

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.

Download

  • M_CreateSparklinesForPivotTable.bas
  • M_ExportModules.bas
  • M_FormatSparklineAxes.bas
  • M_FormatSparkLines.bas
  • M_RangeObject.bas
  • M_SparklinesAdd.bas
  • M_SparklinesDelete.bas
  • M_Worksheet.bas

Additional Resources – Sparklines

, , , , , , ,