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

, , , , , , ,

PTFlash4

In my last post, I showed how to hide the Field Captions of a Pivot Table by changing the font color to match the Interior ColorIndex of the Range. Shane replied on one of the LinkedIn Groups and recommended using the Custom Number Format, “;;;” instead. Let’s give it a try:

PTFieldCaptions1

Select the 3 cells that you want to remove the Captions. Click on the first cell, hold down the Ctrl key and click the other 2 cells:

PTSelectFieldCaptions

Click [Ctrl]+[1] on the keyboard to invoke the Format Cells Dialog.

FormatCellsDialog

Click on “Custom” in the Category Pane

FCD_CustomArrow

In the Type: InputBox, enter 3 semicolons, “;;;” and click, “OK”

FCD_CustomInputF

Field Captions are gone!!

FieldCaptionsManual

VBA

What we do manually, we should try to do with VBA. What if we have many PivotTables on many Worksheets? VBA to the rescue (Assume I restored the Captions so I don’t have to post another screen shot )

Sub PTHideFieldCaptionsCustomNumberFormat()

    'Declare variables
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim pt As PivotTable
        Dim rng As Range
        
    'Excel environment - speed things up
        Application.ScreenUpdating = False

    'Initialize variables
        Set wb = ThisWorkbook

    'Loop all PivotTables in all worksheets in the workbook
    'Set the Number Format of Field Captions so they will not display
        For Each ws In wb.Worksheets
            For Each pt In ws.PivotTables
                Set rng = pt.ColumnRange

                'Set the Number Format of the Field Captions to that nothing is displayed
                    Call SetRangeNumberFormat(rng:=rng)
    
            Next pt
        Next ws

    'Tidy up
        'Destroy objects
            Set rng = Nothing
            Set wb = Nothing

        'Restore Excel environment
            Application.ScreenUpdating = True

End Sub

'--------------------------------------------------------------------
Private Sub SetRangeNumberFormat(rng As Range)
                            
    Dim rngRow As Range
    Dim rngColumn As Range
    Dim rngBig As Range
    Const strNumberFormat As String = ";;;"

    Set rngRow = rng.Offset(1, -1).Resize(rng.Rows.Count - 1, 1)
    Set rngColumn = rng.Offset(0, -1).Resize(1, 2)
    Set rngBig = Union(rngRow, rngColumn)
    
    rngBig.NumberFormat = strNumberFormat
    
    Set rngBig = Nothing
    Set rngColumn = Nothing
    Set rngRow = Nothing

End Sub

FieldCaptionsVBA

Great tip, Shane – thanks!

Other PivotTable Posts At dataprose.org

  1. PivotTable Hide Field Captions – Change Font Color Option
  2. PivotTable Hide Field Captions
  3. PivotTable Conditional Formatting
  4. PivotTable Cell Borders

Additional Resources – PivotTables

  1. Contextures
  2. Peltier Technical Services, Inc.
  3. Chandoo

Additional Resources – Custom Number Formats

  1. A comprehensive guide to Number Formats in Excel – Jon von der Heyden
, ,

PivotTableFlash3

In my last PivotTable post, I showed how to hide PivotTable Field Captions. However, that hides the Filter Arrows as well.

PTNoFieldCaptions

What if you want to hide the Field Captions, but display the filter arrows?

PTArrowsNoLabels

I change the font color of the Field Captions to match the Range Interior ColorIndex

Sub PTFieldCaptionsChangeFontColor()

    'Declare variables
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim pt As PivotTable
        Dim pf As PivotField
        Dim rng As Range
        Dim lngRangeColor As Long

    'Excel environment - speed things up
        Application.ScreenUpdating = False

    'Initialize variables
        Set wb = ThisWorkbook

    'Loop all PivotTables in all worksheets in the workbook
    'Set Font Color of Field Captions to same color as Cell Interior ColorIndex
        For Each ws In wb.Worksheets
            For Each pt In ws.PivotTables
                
                'Get the interior fill color of the Column Range of the Pivot Table
                    Set rng = pt.ColumnRange
                    lngRangeColor = GetRangeColor(rng:=rng)
                    
                'Set the Font Color of the Field Captions to the same color as the Range Interior Color
                    Call ChangeFontColor(rng:=rng, _
                                         lngColor:=lngRangeColor)
    
            Next pt
        Next ws

    'Tidy up
        'Destroy objects
            Set rng = Nothing
            Set wb = Nothing

        'Restore Excel environment
            Application.ScreenUpdating = True

End Sub
'-----------------------------------------------------------------
Private Function GetRangeColor(rng As Range) As Long

    Dim lngColor As Long
    lngColor = rng.Interior.ColorIndex
    GetRangeColor = lngColor
    
End Function
'-----------------------------------------------------------------
Private Sub ChangeFontColor(rng As Range, _
                            lngColor As Long)
                            
    Dim rngRow As Range
    Dim rngColumn As Range
    Dim rngBig As Range

    Set rngRow = rng.Offset(1, -1).Resize(rng.Rows.Count - 1, 1)
    Set rngColumn = rng.Resize(rng.Rows.Count - 1, 1)
    Set rngBig = Union(rngRow, rngColumn)
    
    rngBig.Font.Color = lngColor
    
    Set rngBig = Nothing
    Set rngColumn = Nothing
    Set rngRow = Nothing

End Sub

PTFieldCaptionsInvisible

Other PivotTable Posts At dataprose.org

  1. PivotTable Hide Field Captions
  2. PivotTable Conditional Formatting
  3. PivotTable Cell Borders

Additional Resources

  1. Contextures
  2. Peltier Technical Services, Inc.
  3. Chandoo
, ,

PivotFlashRoman2

I don’t like PivotTable Field Captions

PTwFieldCaptions

You may turn them off manually:

  1. Click on a PivotTable
  2. The PivotTable Tools Tab is activated slightly above the Ribbon
  3. Click on the tab, “Analyze”
  4. In the PivotTable Group, click on the Options drop-down
  5. Click on options
  6. In the PivotTable Options Dialog, click on the Display tab
  7. Clear the tick mark on, “Display field captions and filter drop downs”

PTOptionsDialogFinal

But what if you have many PivotTables, or what if sometimes you want the Field Captions on and sometimes off? Let’s look at some VBA:

Option Explicit

Sub PTDisplayFieldCptions()

    'Declare variables
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim pt As PivotTable
    
    'Excel environment - speed things up
        Application.ScreenUpdating = False
        
    'Initialize variables
        Set wb = ThisWorkbook
        
    'Loop all PivotTables in all worksheets in the workbook
    'Turn off Field Captions
        For Each ws In wb.Worksheets
            For Each pt In ws.PivotTables
                pt.DisplayFieldCaptions = False
            Next pt
        Next ws
        
    'Tidy up
        'Destroy objects
            Set wb = Nothing
            
        'Restore Excel environment
            Application.ScreenUpdating = True
   
End Sub

Or, maybe you would like to toggle the display so if off, tune on and vice versa:

Option Explicit

Sub PTDisplayFieldCptionsToggle()

    'Declare variables
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim pt As PivotTable
    
    'Excel environment - speed things up
        Application.ScreenUpdating = False
        
    'Initialize variables
        Set wb = ThisWorkbook
        
    'Loop all PivotTables in all worksheets in the workbook
    'Turn off Field Captions
        For Each ws In wb.Worksheets
            For Each pt In ws.PivotTables
                If pt.DisplayFieldCaptions = False Then
                    pt.DisplayFieldCaptions = True
                Else
                    pt.DisplayFieldCaptions = False
                End If
            Next pt
        Next ws
        
    'Tidy up
        'Destroy objects
            Set wb = Nothing
            
        'Restore Excel environment
            Application.ScreenUpdating = True

End Sub

PTwFieldCaptionsOff

No more Field Captions

Other PivotTable Posts At dataprose.org

  1. PivotTable Conditional Formatting
  2. PivotTable Cell Borders

Additional Resources

  1. Contextures
  2. Peltier Technical Services, Inc.
  3. Chandoo
, ,

PivotFlashRoman1v2

I wanted to loop through a large workbook with lots of PivotTables to set a common conditional format on the DataBodyRange of each PivotTable.

Here’s my initial PivotTable with no conditional formatting:

PivotTableBigNCF

I would like change the text to red for any value that is less than 0.97 :

Option Explicit

Sub PTConditionalFormatting()

    'Declare variables
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim pt As PivotTable
        Dim rng As Range
        Dim dblLow As Double
        Dim dblHigh As Double
    
    'Excel environment - speed things up
        Application.ScreenUpdating = False
        
    'Initialize variables
        Set wb = ThisWorkbook
        dblLow = 0
        dblHigh = 0.97
        
    'Loop all PivotTables in all worksheets in the workbook
    'Set conditional formatting
        For Each ws In wb.Worksheets
            For Each pt In ws.PivotTables
                Set rng = pt.DataBodyRange
                Call FormatRange(rng:=rng, _
                                 dblValueHigh:=dblHigh, _
                                 dblValueLow:=dblLow)
            Next pt
        Next ws
        
    'Tidy up
        'Destroy objects
            Set wb = Nothing
            
        'Restore Excel environment
            Application.ScreenUpdating = True    
End Sub
'----------------------------------------------------------------------------
Private Sub FormatRange(rng As Range, _
                        dblValueHigh As Double, _
                        dblValueLow As Double)

    With rng
        .FormatConditions.Delete
        .FormatConditions.Add(Type:=xlCellValue, _
                              Operator:=xlBetween, _
                              Formula1:=dblValueHigh, _
                              Formula2:=dblValueLow).Font.Color = vbRed

    End With
End Sub

PTwCF

Very helpful if you have a lot of PivotTables to loop through. The Sub() takes a Range Object as one of the arguments. This means you could use it and pass it any Range Object – not just from PivotTables – Worksheet Range, ListObject Range, other PivotTable Range.

Additional PivotTable Resources

  1. Contextures
  2. Peltier Technical Services, Inc.
  3. Chandoo
, , ,

BorderCollie
I’m a dog person. I have a Yellow Lab, but I’ve always wanted a Border Collie. They are amazing “workhorse”, acrobatic and athletic dogs. Maybe someday I’ll have some land and animals so a Border Collie will be more fitting.

In the meantime, today’s post is not about dogs and farm animals – its about Excel PivotTables.

I like Pivot Tables a lot! I always try to use Pivot Tables before another other solution, if possible, for reporting purposes. But Pivot Table formatting options may not cover the entire spectrum of how we would like to format our Pivots.
PT1_Med
For example, I would like to add cell borders to all Data Range and Row Label items, but not Headers and GrandTotals.
PT_wBorderNotes2
I tried some different PivotTable Styles, but none gave me exactly what I was looking for. In this screen shot, for example, I tried adding adding a border to first column.

ColumnStripe1

There are 2 problems with this:

  1. The Header Row and the Grand Total Row also have the Column Border applied
  2. There does not appear to be a way to apply the same format across all columns

Enter PivotTable Ranges and VBA

Excel PivotTables offer various Ranges within the PivotTable. Jon Peltier covers the various Ranges here, so I won’t recover the information. Make sure you check out Jon’s tutorial – excellent!

DataBodyRange

I colored the DataBodyRange in the PivotTable below with a little VBA
DataBodyRangeFinal

Sub HighlightDataBodyRange()
    'Color the DataBodyRange of a PivotTable

    Dim wb         As Workbook
    Dim ws         As Worksheet
    Dim pt         As PivotTable
    Dim rng        As Range
    Dim lngGrey    As Long
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1")
    lngGrey = RGB(217, 217, 217)
    
    With ws
        For Each pt In ws.PivotTables
            Set rng = pt.DataBodyRange
            rng.Interior.Color = lngGrey
        Next pt
    End With
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
    
End Sub

Looks pretty good, except:

  1. The DataBodyRange includes the Grand Total Row
  2. The DataBodyRange does not include the Row Labels

RowRange

I colored the RowRange in the PivotTable below with a little VBA
RowRangeFinal

Sub HighlightRowRange()
    'Color the RowRange of a PivotTable

    Dim wb          As Workbook
    Dim ws          As Worksheet
    Dim pt          As PivotTable
    Dim rng         As Range
    Dim lngGrey     As Long
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1")
    lngGrey = RGB(217, 217, 217)
    
    With ws
        For Each pt In ws.PivotTables
            Set rng = pt.RowRange
            rng.Interior.Color = lngGrey
        Next pt
    End With
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
    
End Sub

Looks pretty good, except:

  1. The RowRange includes the Grand Total Row
  2. The RowRange includes the Header Row
  3. The RowRange does not include the DataBodyRange identified previously

I have an understanding of a couple of ranges and their shapes. Now I need to reshape the ranges and merge them together.

Resize A Range

RangeReshape

The heavy dashed line in the screen shot shows what the final shape of each range should be if the VBA code works correctly. I filled the resized Ranges with new colors to show that they have been properly resized.

RangesResizedColored

Here’s the Function I came up with for resizing the Ranges. I don’t like it very much, but it works. I think there should be an enumeration for the Range Types of the Excel PivotTable. Maybe there is and I’m not aware of it.

Private Function GetResizedRange(rng As Range, _
                                 strType As String) As Range

    Dim r           As Long
    Dim c           As Long
    
    With rng
        r = .Rows.Count
        c = .Columns.Count
    End With
    
    Select Case strType
        Case "RowRange"
           Set rng = rng.Offset(1).Resize(r - 2, c)
        Case "DataBodyRange"
            Set rng = rng.Resize(r - 1, c)
    End Select
    
    Set GetResizedRange = rng
    Set rng = Nothing

End Function

Borders

FinalCellBorders
The cell borders look great and the original stated objectives have been achieved. I added the cell borders with this sub:

Private Sub AddBorders(rng As Range)

    Dim lngGrey          As Long
    lngGrey = RGB(217, 217, 217)
    
    With rng.Borders
        .LineStyle = xlContinuous
        .Color = lngGrey
    End With

End Sub

The Complete Code

Here’s the complete code so you can copy pate it in one swoop if you so desire:

Option Explicit
Sub AddCellBordersToPivot()
    'Color the DataBodyRange of a PivotTable

    Dim wb              As Workbook
    Dim ws              As Worksheet
    Dim pt              As PivotTable
    Dim rngType         As Range
    Dim rngRow          As Range
    Dim rngData         As Range
    Dim strRangeType    As String
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet1")
    
    With ws
        For Each pt In ws.PivotTables
            'RowRange
                Set rngType = pt.RowRange
                strRangeType = "RowRange"
                Set rngRow = GetResizedRange(rng:=rngType, _
                                             strType:=strRangeType)
                
            'DataBodyRange
                Set rngType = pt.DataBodyRange
                strRangeType = "DataBodyRange"
                Set rngData = GetResizedRange(rng:=rngType, _
                                              strType:=strRangeType)
                                             
            'Add borders
                Call AddBorders(rng:=rngRow)
                Call AddBorders(rng:=rngData)
                
        Next pt
    End With
    
    Set rngType = Nothing
    Set rngRow = Nothing
    Set rngData = Nothing
    Set ws = Nothing
    Set wb = Nothing
    
End Sub

Private Sub AddBorders(rng As Range)

    Dim lngGrey          As Long
    lngGrey = RGB(217, 217, 217)
    
    With rng.Borders
        .LineStyle = xlContinuous
        .Color = lngGrey
    End With

End Sub

Private Function GetResizedRange(rng As Range, _
                                 strType As String) As Range

    Dim r           As Long
    Dim c           As Long
    
    With rng
        r = .Rows.Count
        c = .Columns.Count
    End With
    
    Select Case strType
        Case "RowRange"
           Set rng = rng.Offset(1).Resize(r - 2, c)
        Case "DataBodyRange"
            Set rng = rng.Resize(r - 1, c)
    End Select
    
    Set GetResizedRange = rng
    Set rng = Nothing

End Function

Tidy Up

    Final Thoughts

    That’s it for today. I’m a little surprised there is not an easier way to refer to the Ranges I had to reshape here. I think users would like to apply formats separate from Header Rows and Grand Total Rows. How do you handle these issues? Do you know of a way to achieve this formatting using PivotTable Styles that I was not able to find? Where’d I put the dog’s leash? Time for a walk.

    Downloads

    Download the file from SkyDrive. The file name is PivotTable_CellBorders.xlsm

, ,