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

, , , , , , ,

DustFinal3

The Dust Bowl ravaged the Great Plains from Canada down to Texas from 1930-1936/1940. On May 9, 1934, a large storm arose in the Great Plains pushing 350 million tons of topsoil more than 10K feet high, and carried it all the way out to the Atlantic Ocean leaving 1/4 inch of soil on ships off the coast on May 11.

The History Channel produced a show, aptly named “Black Blizzard”, that does an excellent job of presenting the causes, the effects and some of the remedies of the Dust Bowl – Check it out. If you cannot find it on the History Channel, check your favorite used bookstore or Amazon – well worth it.

Today’s post, however, is not about drought, proper farming techniques or plagues of grasshoppers – it is about pushing reporting to Excel. In my previous post on pushing reports to Excel, I showed you how to push reporting from an Excel Workbook to a new Workbook.

An admirable goal for sure, as it separates the presentation layer from the data and business tiers. Today, I will look at how we might push reports to Excel from Access.

Data Prep

First I’ll need to create a Table in an Access Database and define the datatypes for each of the fields.

Push2_1

Now I can upload the data from the Excel Workbook to the Table in Access

Push2_2

Now that I have the data from the Excel Workbook in the Access Table, I want to change the dates so I can test the dynamic nature of the code I introduced in my last post to ensure that as the dates change, the Group Method work properly on transaction dates in the Pivot Table. I will add 2 months to the original transaction dates by using the DateAdd Function in Access.


 

Read more on the DateAdd Function here

 


The SQL View of the Query:

SELECT Region,
       Rep,
       TrxDate,
       Score,
       DateAdd("m",2,[trxDate]) AS NewDate
FROM tblPush;

Not I’ll turn that into a Make Table Query to create a new Table named tblPushRev

SELECT Region,
       Rep,
       Score,
       DateAdd("m",2,[trxDate]) AS NewDate
INTO tblPushRev
FROM tblPush;

 

Use the SQL clause SELECT INTO to make a new table. Use INSERT INTO to append to an existing table.

 


 

Push2_3

Looking good, all of the original dates have been incremented by 2 months. Now I need to add a new Field named TrxDate, Copy the values from NewDate to TrxDate and remove the field “NewDate”.

Add a new Field named TrxDate and set the datatype to “Date”

ALTER TABLE tblPushRev
ADD TrxDate Date;

Then I can update the values of TrxDate from NewDate

UPDATE tblPushRev
SET TrxDate = NewDate

And remove the NewDate Field

ALTER TABLE tblPushRev
DROP COLUMN NewDate;

Here’s the revised table:

Push2_4

Now that I have the data I want in an Access Table, I need to create a query that I can output as my data source to be used for an Excel Table (ListObject Object). However, what if I have 2 different queries that I want to choose from as my data source? What if I have 10…20….etc? I’ll see if I can create a Query Picker so the user can choose a query at run-time to return the desired data to be used for the Pivot Table in Excel.

Add A Form

First, I’ll add a blank form to my database

frmQueryPicker

I added a blank form and saved it as frmQueryPicker.

Form Properties

PropertySheet

With the form active and in design mode, I clicked on the Property Sheet Icon on the Ribbon and set these form properties:

  • Caption: QueryPicker
  • Default View: Single Form
  • Record Selector: No
  • Navigation Buttons: No
  • Control Box: Yes
  • Min Max Buttons: None
  • Pop Up: Yes

Add A ListBox

ListBox

I added a ListBox to the form and with the form in design mode, I set the properties of the ListBox:

  • Column Count: 1
  • RowSource Type: Table/Query
  • Bound Column: 1
  • On Dbl Click: [Event Procedure]

I also need to add some SQL code to the RowSource Property:

SELECT MSysObjects.Name
FROM MSysObjects
WHERE (((MSysObjects.Type)=5) AND ((MSysObjects.Name) Not Like "~*"))
ORDER BY MSysObjects.Name;

 

MSysObjects are MS Access System Tables. More on MSysObjects here

 


MSysObjects.Type)=5 tells the SQL query to only return items that are query objects. Not Like “~*” tells the SQL Query to ignore hidden System Queries.

ListBoxWQueries

Note that the 3 queries visible as objects in the Access Navigation Pane are now listed in the ListBox.

Command Button…Open Query

Next, I’ll add a Command Button to my form that can be clicked to open the selected query

  • Name: cmdOpen
  • Column Count: 1
  • RowSource Type: Table/Query
  • Bound Column: 1
  • On Click: [Event Procedure]

CmdQryOpen

Command Button…Cancel

I’ll add another Command Button to my form so that I can cancel the form:

  • Name: cmdCancel
  • Caption: Cancel
  • Picture: (none)
  • On Click: [Event Procedure]
  • ControlTip Text: Cancel

CmdCancel

CheckBox AutoClose

The last control I would like to add to the form, is a check box to control whether the form should close or not after the query runs:

  • Name: chkAutoClose
  • Default Value: True

And the check box label:

  • Name: lblAutoClose
  • Caption: Close after opening Query

frmCheckBox

Code The Form

Now I need to add a bit of code behind the form so that all of the controls function as intended. First I need a sub to run whichever query the user selected as well as close the form after the query runs if the check box is “ticked”

CodeBehind3

  1. Make sure the form is active and in design mode. Right-click on the black box on the upper left corner of the form.
  2. In the resulting pop-up menu, click on “Build Event”
  3. In the resulting, “Choose Builder” dialog window, click on “Code Builder”

FormCodeModule

This will take you to the code module for the form. Note that the default event that came up is the Form Load Event. I don’t need that in this case, so I’ll change the control drop-down to General. Now I’ll create a Sub() to open the selected query and if the check box is ticked, close the form.

Option Explicit

Private Sub OpenQuery()
 
    'Declare variables
        Dim strQueryName As String
     
    'Open selected query
        strQueryName = Nz(Me.lstQueries.Value, "")
        If Len(strQueryName) > 0 Then DoCmd.OpenQuery strQueryName
        
    'Close form
        If Me.chkAutoClose.Value = True Then DoCmd.Close acForm, Me.Name
 
End Sub

Now I’ll add the event handlers for the Command Button Click-Events and the Double-click event for the ListBox:

Cancel Button Click Event:

Private Sub cmdCancel_Click()
    
    'if the user clicks the cancel button, close the form
        DoCmd.Close acForm, Me.Name
    
End Sub

Open Button Click Event:

Private Sub cmdOpen_Click()
    
    'Call the OpenQuery Sub()
    'Will open the selected query
        CreateReport
End Sub

ListBox Double Click Event:

Private Sub lstQueries_DblClick(Cancel As Integer)
    
    'Call the OpenQuery Sub()
    'Will open the selected query
        CreateReport
        
End Sub

FormRun

I ran the process by double-clicking on the “qryExcelData” query in the ListBox. The query results are displayed and the form closed as expected. I opened the form again in the foreground just for purposes of the screen shot.

All of the Access Tables, Queries, Forms, and VBA are complete, tested and working properly.

BullwinkleFinal2

And Now For Something Completely Different…

I’m no magician. I cannot pull Rocky out of a magic hat as Bullwinkle is doing here. But I might be able to push Excel reporting from MS Access.


 

edit: As is my usual practice, I am going to use Late Binding in the sample snippets below. A discussion on Late / Early Binding is beyond the scope of this post. Please see these links for a detailed explanation of Late / Early Binding.

  1. Beyond Excel
  2. JP Software Technologies

 


 

Excel Constants

Because I am using Late Binding, Access will not have knowledge of Excel Type Enumerations, so I will need to add several Constants to my project. I won’t use all of the constants below in this project, but since I was looking up the various Types below, I went ahead and created constants for the full Enumerations for each Type:

'XlListObjectSourceType Enumeration (Excel)
'Info: https://msdn.microsoft.com/en-us/library/office/ff820815.aspx
'-------------------------------------------------------------------
Public Const gclxlSrcExternal As Long = 0       'External data source (Microsoft SharePoint Foundation site).
Public Const gclxlSrcModel As Long = 4          'PowerPivot Model
Public Const gclxlSrcQuery As Long = 3          'Query
Public Const gclxlSrcRange As Long = 1          'Range
Public Const gclxlSrcXml As Long = 2            'XML


'XlReferenceStyle Enumeration (Excel)
'Info: https://msdn.microsoft.com/en-us/library/office/ff821207.aspx
'---------------------------------------------------------------------
Public Const gclxlA1 As Long = 1                'Default. Use xlA1 to return an A1-style reference.
Public Const gclxlR1C1 As Long = -4150          'Use xlR1C1 to return an R1C1-style reference.

'XlPivotTableSourceType Enumeration (Excel)
'Info: https://msdn.microsoft.com/en-us/library/office/ff836220.aspx
'-----------------------------------------------------------------------
Public Const gclxlConsolidation As Long = 3     'Multiple consolidation ranges.
Public Const gclxlDatabase As Long = 1          'Microsoft Excel list or database.
Public Const gclxlExternal As Long = 2          'Data from another application.
Public Const gclxlPivotTable As Long = -4148    'Same source as another PivotTable report.
Public Const gclxlScenario As Long = 4          'Data is based on scenarios created using the Scenario Manager.


'XlPivotFieldOrientation Enumeration(Excel)
'Info: https://msdn.microsoft.com/en-us/library/office/ff835617.aspx
'-----------------------------------------------------------------------
Public Const gclxlColumnField As Long = 2       'Column
Public Const gclxlDataField As Long = 4         'Data
Public Const gclxlHidden As Long = 0            'Hidden
Public Const gclxlPageField As Long = 3         'Page
Public Const gclxlRowField As Long = 1          'Row

'XlConsolidationFunction Enumeration(Excel)
'Info: https://msdn.microsoft.com/en-us/library/office/ff837374.aspx
'-----------------------------------------------------------------------
Public Const gclxlAverage As Long = -4106       'Average.
Public Const gclxlCount As Long = -4112         'Count.
Public Const gclxlCountNums As Long = -4113     'Count numerical values only.
Public Const gclxlDistinctCount As Long = 111   'Count using Distinct Count analysis.
Public Const gclxlMax As Long = -4136           'Maximum.
Public Const gclxlMin As Long = -4139           'Minimum.
Public Const gclxlProduct As Long = -4149       'Multiply.
Public Const gclxlStDev As Long = -4155         'Standard deviation, based on a sample.
Public Const gclxlStDevP As Long = -4156        'Standard deviation, based on the whole population.
Public Const gclxlSum As Long = -4157           'Sum.
Public Const gclxlUnknown As Long = 1000        'No subtotal function specified.
Public Const gclxlVar As Long = -4164           'Variation, based on a sample.
Public Const gclxlVarP = -4165                  'Variation, based on the whole population.

Is Excel Running Or Create Excel

First, I’ll create a Function to check whether Excel is already running or not. If Excel is running – use that instance, otherwise, create a new instance of Excel:

Option Explicit

Public Function GetXlApp() As Object

    'Get Excel Application

    'Declare objects
        Dim xlApp As Object
        
    'Check if app is already running, if not, create app
        On Error Resume Next                                                            '
        Set xlApp = GetObject(, "Excel.Application")
        If Err Then
            Set xlApp = CreateObject("Excel.Application")
        End If
        On Error GoTo 0
        
    'Pass object to function
        Set GetXlApp = xlApp
        
    'Tidy up
        Set xlApp = Nothing
            
End Function

Now that I have an instance of Excel, I need to add a Workbook to that instance:

Option Explicit

Public Function GetXlWorkbook(xlApp As Object) As Object

    'Add a workbook to the instance of Excel
    'Returns an Excel Workbook Object

    'Declare objects
        Dim xlBook As Object
        
    'Error handler
        On Error GoTo ErrHandler
        
    'Add a workbook
        Set xlBook = xlApp.Workbooks.Add
        
    'Pass object to function
        Set GetXlWorkbook = xlBook
        
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get workbook", Err.HelpFile, Err.HelpContext
        
    'Tidy up
        Set xlBook = Nothing
            
End Function

Now that I have a Workbook, I need a Worksheet to hold the data that I am going to export from Access:

Option Explicit

Public Function AddWorksheet(wb As Object, _
                             strSheetName As String) As Object
 
    'Declare variables
        Dim ws As Object
        Dim strMySheetName As String
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Add worksheet
        With wb
            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

Now that I have a Worksheet, I need a Range to output the query results to:

    'Small snippet of main procedure
    'Get Excel Range
        Set xlRange = xlWorksheetData.Range("A2")

Transfer Data From DAO Recordset To Excel

As part of my main procedure I load the results of the user-selected query into a DAO Recordset. The entire main procedure is at bottom. Here is the DAO Recordset snippet:

 'Get database, query definition and recordset objects
        Set db = CurrentDb
        Set qdf = db.QueryDefs(strQueryName)
        Set rs = qdf.OpenRecordset

Now I can use the CopyFromRecordset Method of the Range Object to copy the query results from Access to Excel:

'Small snippet of main procedure   
'Copy the recordset to the Excel Range
        xlRange.CopyFromRecordset rs

The CopyFromRecordset Method only copies the records of the recordset, not the Field Headers, so I need to copy those to the Excel Worksheet separately:

'Small snippet of main procedure
'Copy field headers from the recordset to the Excel Worksheet
        For i = 1 To rs.Fields.Count
            xlWorksheetData.Cells(1, i).Value = rs.Fields(i - 1).Name
        Next i

QryToExcelRange

The selected query has been output to an Excel Worksheet (inset).

Add A ListObject To The New Range

I want to use a ListObject (Excel Table) as the data source for a Pivot Cache, so I’ll add a ListObject directly over the Range Object:

Option Explicit

Public Function GetListObject(ws As Object)
 
    'Declare objects
        Dim rng As Object
        Dim C As Object
        Dim lo As Object
        Dim xlSrcRange As Object
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Create range object
        Set rng = ws.UsedRange
        Set C = rng.Cells(1, 1)
 
    'Add listobject
        Set lo = ws.ListObjects.Add( _
                        SourceType:=gclxlSrcRange, _
                        Source:=rng, _
                        Destination:=C)
 
    'Pass the object to the function
        Set GetListObject = lo
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get ListObject", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set lo = Nothing
        Set C = Nothing
        Set rng = Nothing
 
End Function

Add A Pivot Cache

I just added a ListObject (Excel Table). I’ll use that as the data source for a Pivot Cache:

Option Explicit

Public Function GetPivotCache(wb As Object, _
                              lo As Object)
 
    'Declare Objects
        Dim pc As Object
    
    'Declare variables
        Dim strPivotCacheSource As String
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Pivot cache source
        strPivotCacheSource = lo.Parent.Name & "!" & _
                              lo.Range.Address(ReferenceStyle:=gclxlR1C1)
 
    'Create pivot cache
        Set pc = wb.PivotCaches.Create( _
                        SourceType:=gclxlDatabase, _
                        SourceData:=strPivotCacheSource)
 
    'Pass object to function
        Set GetPivotCache = pc
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot cache", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set pc = Nothing
 
End Function

Add A Worksheet For The Pivot Table Report

Now that I have a Pivot Cache, I need to add a Worksheet for the Pivot Table Report:

Option Explicit

Public Function AddWorksheet(wb As Object, _
                             strSheetName As String) As Object
 
    'Declare variables
        Dim ws As Object
        Dim strMySheetName As String
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Add worksheet
        With wb
            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 A Pivot Table

Now that I have a Worksheet, I can add a Pivot Table:

Option Explicit

 Public Function GetPivotTable(pc As Object, _
                              ws As Object, _
                              strPivotTableName As String, _
                              Optional ByVal lngRowPlacement As Long = 3, _
                              Optional ByVal lngColPlacement As Long = 3)
 
    'Declare Objects
        Dim pt As Object
        Dim rng As Object
 
    'Declare variables
        Dim strPivotPlacement As String
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Create range
        Set rng = ws.Cells(lngRowPlacement, lngColPlacement)
 
    'Pivot table placement
        strPivotPlacement = ws.Name & "!" & _
                            rng.Address(ReferenceStyle:=gclxlR1C1)
 
    'Create pivot table
        Set pt = pc.CreatePivotTable( _
                    TableDestination:=strPivotPlacement, _
                    TableName:=strPivotTableName)
 
    'Pass object to function
        Set GetPivotTable = pt
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set rng = Nothing
        Set pt = Nothing
 
End Function

Add Pivot Fields To Pivot Table

Now that I have a Pivot Table, I can add Pivot Fields. I am using a Select Case Statement to handle the correct Pivot Fields based on the name of the query the user selected. You will need to add additional Case Statements as you add more queries that require different fields and different consolidation functions (see global constants above):

Option Explicit

Public Sub AddFieldsToPivot(pt As Object, _
                            strQuery As String)
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Add fields to pivot table
        With pt
            Select Case strQuery
                Case "qryExcelData"
                   'Row fields
                       .PivotFields("Region").Orientation = gclxlRowField
                       .PivotFields("Region").Position = 1
        
                       .PivotFields("Reps").Orientation = gclxlRowField
                       .PivotFields("Reps").Position = 2
           
                   'Column fields
                       .PivotFields("TrxDate").Orientation = gclxlColumnField
                       .PivotFields("TrxDate").Position = 1
        
                   'Value fields
                       .AddDataField .PivotFields("Score"), _
                           Caption:="Avgerage of Score", _
                           Function:=gclxlAverage
                Case Else
                    MsgBox "The selected query is not an option for a Pivot Table"
                    Err.Raise 513                                                       'Custom error
            End Select
        End With
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table fields", Err.HelpFile, Err.HelpContext
        Err.Clear
 
End Sub

PivotFields

Group Dates By Month

Notice that the Pivot Table currently displays each day in a Column Field. I would prefer to group the dates based on the month. I can achieve this by using the Group Method of the Range Object. So first I will need to find the Range to group.

Get A Range From A Pivot Table

I need to get the first Cell in the PivotField “TrxDate” DataRange, so I’ll use the Pivot Item DataRange.


 

Read more on various ranges within a pivot table and their special VBA range names on Jon Peltier’s site

 


Option Explicit

Public Function GetPivotTableRange(pt As Object, _
                                   strRangeType As String, _
                                   Optional ByVal strPivotField As String = vbNullString) As Object
 
    'Pivot field Range type documentation:
    'http://peltiertech.com/referencing-pivot-table-ranges-in-vba/                  <-Jon Peltier
 
    'String range types:
        'PivotItemDataRange
        'DataBodyRange
 
    'Declare objects
        Dim rng As Object
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Create pivot table range
        Select Case strRangeType
            Case "PivotItemDataRange"
                Set rng = pt.PivotFields(strPivotField).DataRange.Cells(1, 1)
            Case "DataBodyRange"
                Set rng = pt.DataBodyRange
            Case Else
                MsgBox "That is not an option"
                Err.Raise 513
        End Select
 
    'Pass object to function
        Set GetPivotTableRange = rng
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table range", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set rng = Nothing
 
End Function

Note that I set the rng object to just the first cell of the Range actually returned by the DataRange.

Group Pivot Table Dates

Now that I have the first cell of the DataRange, I am ready to group the range. Recall, I want to group dates by month. One of the optional parameters of the Group Method is Periods; which is an array of Boolean values that specify the period for the group.


 

Read more on the Group Method of the Range Object here

 


The snippet from the main procedure. Note that I set the 5th element of the Array to “True”. This specifies that the grouping should be by months as per the documentation on MSDN.


'Group pivot table dates
    Periods = Array(False, False, False, False, True, False, False)
    Call GroupRange(rng:=xlPivotTableRange, _
                    varrPeriods:=Periods)

And the Group Range Sub():

Option Explicit

Public Sub GroupRange(rng As Object, _
                      varrPeriods() As Variant)
 
    '=============================================================================
    'Uses the Group Method of the Range Object
    'Only works if Range Object is single cell in PivotTable field’s data range
    'https://msdn.microsoft.com/EN-US/library/office/ff839808.aspx
    'Group(Start, End, By, Periods)
 
    'Array element   Period
    '----------------------
        '1          Seconds
        '2          Minutes
        '3          Hours
        '4          Days
        '5          Months
        '6          Quarters
        '7          Years
 
    '==============================================================================
 
    'Declare objects
        Dim C As Object
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Get first cell of range
        Set C = rng.Cells(1, 1)
 
    'Group range
        C.Group _
            Periods:=varrPeriods()
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Group pivot field data range", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set C = Nothing
 
End Sub

GroupDates

The individual dates in the Column Fields have been grouped by month and the groups have been collapsed to display just the average score for each Rep for each month.

Format DataFields

The Pivot Table is looking good, next I would like to format the DataFields to only display to the hundredths:

Public Sub FormatPivotField(pt As Object)
 
    'Declare objects
        Dim pf As Object
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Format datafields
        With pt
            For Each pf In .DataFields
                pf.NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
            Next pf
        End With
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Format DataFields", Err.HelpFile, Err.HelpContext
 
End Sub

PTFormatNumbers

Set The Column Widths

Another way to improve readability of the Pivot Table is to set all columns to a consistent width:

Option Explicit

Public Sub PivotTableRangeColWidth(pt As Object)
 
    'Declare objects
        Dim rng As Object
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Get range oject from pivot table
        Set rng = GetPivotTableRange(pt:=pt, _
                                     strRangeType:="DataBodyRange")
 
    'Set column width
        rng.ColumnWidth = 15
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Range Column Width", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set rng = Nothing
 
End Sub

PTColumnWidths

There is a lot more I could do to format the final Pivot Table, but this post is already long enough.

The Main Sub()

Here’s the Main Sub() that calls all other Functions() and Subs()

Option Explicit

Private Sub CreateReport()
    
    'Declare objects
        Dim db As DAO.Database
        Dim qdf As DAO.QueryDef
        Dim rs As DAO.Recordset
        Dim xlApplication As Object
        Dim xlWorkbook As Object
        Dim xlWorksheetData As Object
        Dim xlWorksheetReport As Object
        Dim xlRange As Object
        Dim xlListObject As Object
        Dim xlPivotCache As Object
        Dim xlPivotTable As Object
        Dim xlPivotTableRange As Object
 
    'Declare variables
        Dim strQueryName As String
        Dim i As Long
        Dim Periods() As Variant
        
    'Error handler
        On Error GoTo ErrHandler
     
    'Open selected query
        strQueryName = Nz(Me.lstQueries.Value, "")
        If Len(strQueryName) > 0 Then DoCmd.OpenQuery strQueryName
          
    'Close form
        If Me.chkAutoClose.Value = True Then DoCmd.Close acForm, Me.Name
        
    'Get database, query definition and recordset objects
        Set db = CurrentDb
        Set qdf = db.QueryDefs(strQueryName)
        Set rs = qdf.OpenRecordset
        
    'Get Excel Application
        Set xlApplication = GetXlApp()
        xlApplication.Visible = True
    
    'Get Excel Workbook
        Set xlWorkbook = GetXlWorkbook(xlApp:=xlApplication)
        
    'Get Excel Worksheet
        Set xlWorksheetData = xlWorkbook.Worksheets(1)
        xlWorksheetData.Name = "Data"
        
    'Get Excel Range
        Set xlRange = xlWorksheetData.Range("A2")
        
    'Copy the recordset to the Excel Range
        xlRange.CopyFromRecordset rs
        
    'Copy field headers from the recordset to the Excel Worksheet
        For i = 1 To rs.Fields.Count
            xlWorksheetData.Cells(1, i).Value = rs.Fields(i - 1).Name
        Next i
        
    'Add a ListObject Object
        Set xlListObject = GetListObject(ws:=xlWorksheetData)
    
    'Add a Pivot Cache
        Set xlPivotCache = GetPivotCache(wb:=xlWorkbook, _
                                         lo:=xlListObject)
        
    'Add a worksheet for the pivot table
        Set xlWorksheetReport = AddWorksheet(wb:=xlWorkbook, _
                                             strSheetName:="rpt")
                                             
    'Add a pivot table
        Set xlPivotTable = GetPivotTable(pc:=xlPivotCache, _
                                         ws:=xlWorksheetReport, _
                                         strPivotTableName:="PivotTable1")
                                         
    'Add pivot fields to pivot table
        Call AddFieldsToPivot(pt:=xlPivotTable, _
                              strQuery:=strQueryName)
                              
    'Get pivot table range to group
        Set xlPivotTableRange = GetPivotTableRange(pt:=xlPivotTable, _
                                                   strRangeType:="PivotItemDataRange", _
                                                   strPivotField:="TrxDate")
                                                   
    'Group pivot table dates
        Periods = Array(False, False, False, False, True, False, False)
        Call GroupRange(rng:=xlPivotTableRange, _
                        varrPeriods:=Periods)
                        
    'Format pivot table values
        Call FormatPivotField(pt:=xlPivotTable)
        
    'Format pivot table column width
        Call PivotTableRangeColWidth(pt:=xlPivotTable)
        
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Create Report", Err.HelpFile, Err.HelpContext
        
    'Tidy up
        Set rs = Nothing
        Set qdf = Nothing
        Set db = Nothing
        
        Set xlRange = Nothing
        Set xlPivotTableRange = Nothing
        Set xlListObject = Nothing
        Set xlPivotTable = Nothing
        Set xlPivotCache = Nothing
        Set xlWorksheetData = Nothing
        Set xlWorksheetReport = Nothing
        Set xlWorkbook = Nothing
        Set xlApplication = Nothing

End Sub

Homework

There’s more I could do here, but this post is long enough and I wanted to leave some meat on the bone. Additional items to be added:

  • Additional Pivot Tables
  • Charts and/or Pivot Charts
  • Slicer Cache
  • Slicers
  • Worksheet Display Settings
  • Page Setup Settings For Printing

Downloads

You may download the Access Database and/or the code modules (.bas files) from OneDrive.

  • Push.accdb
  • Form_frmQueryPicker.cls
  • M_Globals.bas
  • M_GroupPivotTableRange.bas
  • M_PushToExcel.bas
  • M_XlAddWorksheet.bas
  • M_XlApp.bas
  • M_XlFormatPivotField.bas
  • M_XlListObjects.bas
  • M_XlPivotCache.bas
  • M_XlPivotFields.bas
  • M_XlPivotTable.bas
  • M_XlPivotTableRange.bas
  • M_XlPivotTableRangeColWidth.bas
  • M_xlWorkbook.bas

OneDrive

Additional Pivot Table Resources – Around The Excel Horn

Some authors of my favorite resources for working with Pivot Tables:

Additional Pivot Table Resources – dataprose.org

Some additional resources for working with Pivot Tables on my blog

Tidy Up

That’s all for today. A very long post – even by my standards. Storing data in a database (even if small and simple as Access) and then working with that data for reporting purposes in Excel makes a lot of sense. Highly recommended!

, , , , , , , , , , , , , , , , , ,

Pre3

Here’s Bill Bowerman (facing) with Steve “Pre” Prefontaine (back turned). Pre was an amazing long distance runner, at one point in his career holding 9 different long distance running records. 4 of Pre’s records remain unbroken to this day. Pre died in an automobile accident in May, 1975. He was only 24 years old.

Bowerman and one of his former student athletes founded Blue Ribbon Sports which eventually became Nike, [Just Do It]

The 1997 movie, Prefontaine stars Jared Leto as Pre and R. Lee Ermey as Bowerman. Ermey is always entertaining in everything he does in his over the top approach and larger than life portrayals, check it out.

Today’s post, however, is not about running or movies, it is about the DoCmd Object of the Access Object Model. The DoCmd Object has 66 different Methods as of Office 2013. I’ll look at some of the Methods over a series of posts and how they may be leveraged in Microsoft Office development. I’ll begin with the TransferSpreadsheet Method.

I won’t bore you by reviewing the parameters of the Method, you can read those for yourself here. Instead, I’ll jump right in and demonstrate some VBA you may use to update your Access Tables from Excel Worksheets.


    edit: This is a re-boot of sorts. Readers of this blog (both of you) will recall I posted an article back in November, 2013. That article was lost to the cybersphere during the great melt down of aught thirteen when I hosed my function.php file.


TransferSpreadsheet Method

I want to transfer a list of NFL teams from an Excel Worksheet to a Table in an Access Database. This will be a Dimension (Dim) Table, so all I need in the Table is a Primary Key and the name of each Team. I will want to automate this routine and attempt to insert any number of teams at any time based on transformative process I use in Excel to create files that I will want to attempt to insert into the Team Dimension Table. It is imperative that a team only exist 1 time in the Dimension (dim) Table.

tblTeamsPK

I created the table and named it dimTeams. I named the first field TeamKey, set the field as the Primary Key for the table and set the datatype to autonumber.

tblTeamsDesignFieldPropertiesFinal

Next, I added the field, TeamName, set the datatype to Short Text, and in the Field Properties pane, changed the Indexed property to Yes (No Duplicates). I saved all changes to the table. I am now ready to add some VBA to Load the table using DoCmd.TransferSpreadsheet.

DoCmd.TransferSpreadsheet VBA

Option Compare Database

Sub TransferSpreadsheet()
    'Author: Winston Snyder
    'Date: 4/5/2014
    'Purpose: Transfer Excel Worksheet to Access Table
    
    'Declare variables
        Const strPATH   As String = "C:\tmp\"
        Const strFILE   As String = "xlTeams.xlsx"
        Const strTABLE  As String = "dimTeams"

    With DoCmd
        'Turn warnings off
            .SetWarnings False

        'Transfer spreadsheet
            .TransferSpreadsheet _
                TransferType:=acImport, _
                TableName:=strTABLE, _
                FileName:=strPATH & strFILE, _
                HasFieldNames:=True

        'Turn warnings on
            .SetWarnings True
            
    End With
    
End Sub

dimTeamsLoadedFinal

That works well. All current 32 teams of the NFL were loaded to the dimTeams Table. I’ll try to load the Table again. Recall, I set the Index property to Yes (No Duplicates) so no duplicate values should be loaded to the Dimension Table. I’ll comment out the 2 lines in code that turn warning messages off and back on so I can review any error messages :

        'Turn warnings off
            '.SetWarnings False

        'Turn warnings on
            '.SetWarnings True

Here is the information message I receive from Access when I re-spin the code :

UnableToAppend

Because I set the Index property on the TeamName field, to Yes (No Duplicates), all 32 records are rejected and nothing additional is loaded. Next, I’ll amend the Excel Workbook to add teams from the now defunct NFL Europe just so I can test that teams will indeed be added if new teams are added to the Excel Workbook.

xlNFLEuropeTeams

I added 9 teams from NFL Europe to the Excel Workbook and ran the VBA code again :

dimTeamsTableUpdateFinal

Only the 9 new team names from the Excel Workbook were added to the dimTeams table. Everything is working as I intended. I deleted everything from the dimTeams table and Compacted and Repaired the Database to force autonumbering to start at 1 again on the next step.

Make The VBA More Dynamic / Flexible

I don’t like that I hard-coded in VBA Code the file path, the file name and the table name. I’ll introduce some functions to make the code a bit more flexible and dynamic.

FileDialogFilePicker

I have discussed the FileDialog Property of the Application Object in previous posts. FileDialog’s are a great way to interact with users at run-time to allow the user to select a file to perform operations on.

First, I added these 4 global constants to my Globals Module. These constants are based on the MSOFileDialogType Enumeration

Public Const gclmsoFileDialogFilePicker = 3                 'File Picker
Public Const gclmsoFileDialogFolderPicker = 4               'Folder Picker
Public Const gclmsoFileDialogOpen = 1                       'Open
Public Const gclmsoFileDialogSaveAs = 2                     'SaveAs
Public Function GetSelectedFile() As String
     
    'Declare variables
        Dim fd                  As Object
        Dim strFileName         As String
 
    'Initialize variables
        Set fd = Application.FileDialog(gclmsoFileDialogFilePicker)
    
    'User - select file
        With fd
            .AllowMultiSelect = False
            .Show
            strFileName = .SelectedItems(1)
        End With
 
    'Pass value to function
        GetSelectedFile = strFileName
        
    'Tidy up
        Set fd = Nothing
    
End Function

I selected the file, “xlTeams.xlsx”. The function returns :

C:\tmp\xlTeams.xlsx

So I’ll need a functions to split the folder path and file name into separate substrings.

GetSegmentsFromFullFileName

This function returns either a substring of either the path or the file name. If the user specifies, “strSubstringType:=Path”, then the path will be returned. Otherwise the file name without the path will be returned.

Public Function GetSegmentsFromFullFileName(strCompleteFileName As String, _
                                            strSubstringType As String) As String

    'Declare variables
        Dim strSegment As String

    'Get substring segment
        Select Case strSubstringType
            Case "Path"
                strSegment = Mid(strCompleteFileName, 1, InStrRev(strCompleteFileName, "\"))
            Case Else
                strSegment = Trim(Mid(strCompleteFileName, InStrRev(strCompleteFileName, "\") + 1, Len(strCompleteFileName) - InStrRev(strCompleteFileName, "\")))
        End Select
    
    'Pass value to function
        GetSegmentsFromFullFileName = strSegment

End Function

I selected the file, “xlTeams.xlsx”. The function returns either:

C:\tmp\ or xlTeams.xlsx depending on the value the user passes for “strSubstringType”

I need one more function to take the file name and convert it to the Access Table Name.

GetTableNameFromFileName

Public Function GetTableName(strFile As String) As String

    'Declare variables
        Dim strTable As String

    'Get table name from file name
    'In Len, include front and end segments to drop
        strTable = "dim" & Trim(Mid(strFile, 4, Len(strFile) - 7))

    'Pass the value to a function
        GetTableName = strTable
End Function

The function returns :

dimTeams

Now I just need to revise the original sub procedure to use the functions instead of hard-coding in values for the path, the file name and the name of the Access Table.

TransferSpreadsheetUsingFunctions

Sub TransferSpreadsheetUsingFunctions()

    'Purpose: Transfer Excel Worksheet to Access Table
    'Log    :
    '---------------------------------------------------------------------------------------------------------------------------------------------------
    'Date               Developer                   Action                      Comments
    '---------------------------------------------------------------------------------------------------------------------------------------------------
    '4/5/2014           ws                          Created
    '4/6/2014           ws                          Modified                    Added functions to remove hard-coding of path, file name and table name
    
    'Declare variables
        Dim strFullFileName             As String
        Dim strPath                     As String
        Dim strFileNameSubstring        As String
        Dim strTable                    As String

    'Initialize variables
        'User - call file dialog to get file
            strFullFileName = GetSelectedFile()
            
        'Get folder path from full file name
            strPath = GetSegmentsFromFullFileName(strCompleteFileName:=strFullFileName, _
                                                  strSubstringType:="Path")
            
        'Get file name substring from full file name
            strFileNameSubstring = GetSegmentsFromFullFileName(strCompleteFileName:=strFullFileName, _
                                                               strSubstringType:="File")
            
        'Get Access Table name from the file name
            strTableName = GetTableName(strFile:=strFileNameSubstring)
            
    'Transfer spreadsheet to table
        With DoCmd
            'Turn warnings off
                .SetWarnings False
    
            'Transfer spreadsheet
                .TransferSpreadsheet _
                    TransferType:=acImport, _
                    TableName:=strTableName, _
                    Filename:=strPath & strFileNameSubstring, _
                    HasFieldNames:=True
    
            'Turn warnings on
                .SetWarnings True
                
        End With
    
End Sub

dimTeamsLoadFinal

Great! That works well. The dimTeams Table is once again loaded. But what if there is more than one file to load?

Multiple Files…Multiple Tables

So far, so good. But chances are good you may have multiple files to load to multiple tables. I have code above to load one file to one table, so now I just need to add the ability to loop through files in a folder and load each file while I am looping.

LoadFilesToTables2

To loop through files in a folder, I like to use the FileSystemObject (FSO) which is a top level object in Microsoft Scripting Runtime Library (scrrun.dll). I covered FSO previously as part of my series on Microsoft Scripting in VBA.


    edit: As per usual, I am going to use Late Binding in the sample snippets below. A discussion on Late / Early Binding is beyond the scope of this post. Please see these links for a detailed explanation of Late / Early Binding.

    1. Beyond Excel
    2. JP Software Technologies


Some New Functions

I’ll need some new functions to create the FileSystemObject (FSO) and to work with the FileDialog Object.

Create FileSystemObject

This function creates a FileSystemObject. This is the route to go if you are using Late Binding for creating an object.

Public Function GetFileSystemObject() As Object
      
    On Error Resume Next
    Set GetFileSystemObject = CreateObject("Scripting.FileSystemObject")
      
End Function

File Dialog

I modified the FileDialog Function I introduced earlier. The function now accepts one argument, “strDialogType” so the function may be used to return either the name of a folder or the name of a file based on the value of strDialogType as declared by the user :

Public Function GetFDObjectName(strDialogType As String) As String

    'Returns either the name of a folder or the name of a file based on the type passed into the function, "strDialogType"
  
    'Declare variables
        Dim fd As FileDialog
        Dim strObjectName As String
        Dim strTitle As String
        
    'Choose if user requested a folder dialog or other
        Select Case strDialogType
            Case "Folder"                                                               'Folder Dialog
                strTitle = "Please select a folder"
                Set fd = Application.FileDialog(gclmsoFileDialogFolderPicker)
            Case Else
                strTitle = "Please select a file"                                       'File Dialog
                Set fd = Application.FileDialog(gclmsoFileDialogFilePicker)
        End Select
        
    'Invoke filedialog
        With fd
            .Title = strTitle
            .AllowMultiSelect = False
            .Show
            strObjectName = .SelectedItems(1)
        End With
        
    'Pass value to function
        GetFDObjectName = strObjectName
    
    'Tidy up
        Set fd = Nothing
        
End Function

The Final Sub()

I took the original Sub() and made it a Private Sub() of the new main Sub(). The Main Sub() gets the Absolute Path of a file and passes it to the Private Sub(). The Main Sub() is immediately below, the Private Sub() follows the Main Sub()

Option Compare Database

Sub LoadExcelFilesToAccessTables()
     
    'Author     :   Winston Snyder
    'Date       :   4/14/2014
    'Purpose    :   Load files from folder to target tables in database
     
    'Declare variables
        Dim fso As Object
        Dim fsoFoler As Object
        Dim strFolderInputFiles As String
        Dim strAbsolutePath As String
 
    'User - choose a folder that contains files to be loaded to the database
        strFolderInputFiles = GetFDObjectName(strDialogType:="Folder")
 
    'Create a FileSystemObject (FSO)
        Set fso = GetFileSystemObject
         
    'Get an FSO folder for the input files
        Set fsoFolder = fso.GetFolder(strFolderInputFiles)
         
    'Load each file in the folder to it's respective Table in Access
        For Each fsoFile In fsoFolder.Files
            strAbsolutePath = fso.GetAbsolutePathName(fsoFile)
            Call TransferSpreadsheetRoutine(strFullFileName:=strAbsolutePath)
        Next fsoFile
         
    'Tidy up
        Set fsoFolder = Nothing
        Set fso = Nothing
 
End Sub




Private Sub TransferSpreadsheetRoutine(strFullFileName As String)

    'Arguments: Accepts 1 argument, "strFullFileName" as a string
    'Resuts   : Split full file name into path and file name segments
    '           Create table name from file name
    '           Transfer spreadsheet to target database table

    
    'Declare variables
        Dim strPath                     As String
        Dim strFileNameSubstring        As String
        Dim strTable                    As String

            
        'Get folder path from full file name
            strPath = GetSegmentsFromFullFileName(strCompleteFileName:=strFullFileName, _
                                                  strSubstringType:="Path")
            
        'Get file name substring from full file name
            strFileNameSubstring = GetSegmentsFromFullFileName(strCompleteFileName:=strFullFileName, _
                                                               strSubstringType:="File")
            
        'Get Access Table name from the file name
            strTableName = GetTableName(strFile:=strFileNameSubstring)
            
    'Transfer spreadsheet to table
        With DoCmd
            'Turn warnings off
                .SetWarnings False
    
            'Transfer spreadsheet
                .TransferSpreadsheet _
                    TransferType:=acImport, _
                    TableName:=strTableName, _
                    FileName:=strPath & strFileNameSubstring, _
                    HasFieldNames:=True
    
            'Turn warnings on
                .SetWarnings True
                
        End With

End Sub

TablesUpdated

I changed the view of the Navigation Pane in MS Access to View By Details. There are a couple of items of note:

  1. The dimTeams table was created on 11/7/2013 and modified on 4/16/2014
  2. The other 2 tables were created on 4/16/2014 and modified on 4/16/2014

I intentionally deleted the 2 tables before spinning the process, I wanted to show you, that when you use the TransferSpreadsheet Method, if the table does not already exist, it will be created! That is pretty cool. However, I have seen instances when I use TransferSpreadsheet Method and I did not explicitly create the table and setup all the datatypes for each field – I end up with some unwanted results. So I now create all tables, fields ahead of time so I explicitly control all datatypes.

Power Pivot

PowerPivotImport

I now have a great process for keeping my Dimension (dim) Tables up-to-date with any kind of frequency that I need – usually monthly after month-end close to pick up any changes in accounts, or organizational structure. I just spin my process to create my Excel files, spin the DoCmd process to import the Excel file to the appropriate dim table and refresh the Data Model in the Power Pivot window.

PowerPivotRefresh

Slowly Changing Dimensions (SCD)

What I demonstrated here, is an example of a Type 2 Slowly Changing Dimension (SCD). There are 6 different SCD’s. You may read more about them here.

If this Data Model was properly constructed, I would most likely have 3 different entries (maybe more) for the now Arizona Cardinals.

  1. The club was established in Chicago in 1898
  2. They moved to St. Louis Missouri in 1960
  3. They moved to Phoenix, Arizona in 1988

There are many other examples along those lines – so Type 2 SCD.

Tidy Up

That’s it for today – lot’s to do on my Honey DoCmd List. This is a fairly long post with hopefully a little something for everyone.

, , , , , , , ,

StoogesFinal

I’m a huge fan of the 3 Stooges (pictured here) and Curly Howard in particular. Without a doubt, they appeal to my 5 year-old sense of humor with their brand of inane slapstick.

Shemp Howard, Curly’s brother, was ok, but Curly Joe? Ah Marone! Don’t even get me started!

Curly Howard was pure slapstick comedic genius – undisputed. Unfortunately, Curly left us far too early.

Today’s post, however, is not about the Stooges or Curly. It is about Cartesian Products and creating “Controlled” random data.

Random Data Generators

Dick Kusleika and Jimmy Pena offer Random Data Generator add-ins on their respective sites. Jimmy’s will cost you a couple of bucks:

  1. Daily Dose of Excel – Dick Kusleika
  2. JP Software Technologies – Jimmy Pena

Cartesian Product

A Cartesian Product returns everything from Table A with everything from Table B which is generally unwanted and means you have not configured your join(s) properly.

Here I have a couple of Tables of NFL Teams and Divisions that I would like to join in a query to get the teams into their respective divisions.

AccessTables

Here’s my query in the Query Design Window

NFLQry1

When I run the query, I get a Cartesian Product where every team is returned against every division. It is not possible for the Arizona Cardinals to belong to 8 different divisions:

NFLCartesian

Revised Join

I revised the join to show the correct relationship between Division and Team:

NFLTeamDivRelate

Now I get the correct results when I run the query:

NFLTeamDivRelateData

Create “Controlled” Sample / “Dummy” Data

Now, I want to create some sample data to load for a PivotTable so I want some random values, but I want to control the Row Label and Column Field values. For Row Labels, I’ll use Regions and Representatives. This is a standard relationship, so we will reflect as such in the query design:

RegionsReps

Additionally, I would like to generate some sample (dummy) data for each rep for each day of the year. I’ll use a Cartesian Join to generate the dataset:

RegionsRepsCart

Note that there is no join between the Reps/Regions and Dates tables. The query results:

RegionsRepsCartResultRecAnnon

Let’s Create Some Random / “Dummy” Data

I’ll need a function in Access that I can add to the query to generate a random number

Public Function GetRandomValue(Optional x As Integer) As Double

    Dim dblRandom As Double
    
        dblRandom = (1000000 - 500000 + 1) * Rnd() + 500000
        GetRandomValue = dblRandom
        
End Function

Note the difference: in MS Access, the Built-in Function for generating a random number is Rnd(). In MS Excel, it’s Rand(). I added the User-Defined Function to the Query Design Grid and named the output field as SalesAmount:

QueryDesignRandomFunctionFinal

And the query results:

QueryRandomResultsFinal

The first value looks great, but do you notice how the same value keep repeating through every row? That’s not very random. The problem is the function is only called one time, so the random value is generated once and then repeated on every row. I’ll need to pass a unique value to the function to make it generate a new random number on every row of the query results.

To create the unique value, I’ll concatenate 3 fields in the query together

[RepName] & "-" & [RegionName] & "-" & [RecordDate]

I can then pass that as a unique value to the Random Function. First, I need to modify the Random Function a little bit. The Function was looking for me to pass an Integer Value. So I’ll just change the argument to a Variant.

'Old
Public Function GetRandomValue(Optional x As Integer) As Double

'New
Public Function GetRandomValue(v As Variant) As Double

Now I can update the query in the design grid:

QueryRandomValueUpdate

And the query results:

QueryResultsRandomValuesFinalAnno

Perfect! Ready to connect to the query with Excel PivotTable and pivot and slice ’til you get your fill.

MS Query

I was able to generate some random data with some controlled data in MS Access, can I repeat the same in MS Query? I’ll begin by copying the from each of the 3 Access tables to 3 different worksheets in an Excel Workbook:

AccessDataToExcel

Next, I’ll import the data from the 3 worksheets into MS Query

  1. Click on Data Tab on the Ribbon
  2. In the Get External Data group, click on From Other Sources
  3. In the resulting pop-up menu, click on From Microsoft Query

MSQueryMenuSteps

At the Choose Data Source Dialog, click on Excel Files and OK

ChooseDataSourceDiaAnn

At the Select Workbook Dialog, browse through the directory structure to find the workbook that contains the data that you would like to use to import from including the the current workbook.

SelectWBDiaAnn

At the Query Wizard – Choose Columns Dialog, expand nodes next to the tables in the panel on the left, find the columns from each table that you would like included in your query results, use arrow buttons to add and remove items from the pane, “Columns in your query”

QryWizardChooseColDia

You may receive an error message:

The Query Wizard can not continue because it can not join the tables in your query. You must join the tables manually in Microsoft Query by dragging the fields to join between the tables.

Go ahead and click, “OK”. The Query Results will be displayed with no joins between the tables:

MicrosoftQueryInitialResultsAnno

In the initial Query Results Window, notice that there are no Joins, so MS Query went ahead and created a Cartesian Product of Table A, B and C thus returning 14.6K records.

Go ahead and add the Join, by dragging RegionKey from the Reps Table to RegionsKey on the Regions Table. The query results will update to the 3,650 records as expected:

MicrosoftQueryUpdateResultsAnno

Once you have the query returning the correct results, click on, “Return Data” icon on the MS Query Toolbar.

MicrosoftQryReturnDataIconAnno

At the Import Data Dialog, select the option to view the data as a Table in the workbook and at the where to put the data prompt, choose, “New worksheet” option.

ImportDataDiaAnn

In $D$1 add a title for the column that will hold values such as “SalesAmount”. In $D$2, enter a randomization formula in the general form =Rand()*(High-Low)+Low. I used =Rand()*(1000000-500000)+500000. Double-click on the fill handle in the lower-right corner of the cell to send the formula to the bottom.

ExcelTableRandFrmla

ExcelTableSalesAmounts

Looks great! Ready to pivot and slice ’til you get your fill.

Tidy Up

    Final Thoughts

    Hopefully, I presented a case for when a Cartesian Product can be a good thing. How many times have you copied the same data move down 20 rows..paste..repeat..over and over? Lots I bet – I know I have.

    I prefer the MS Access method above, but I wanted to present some alternatives. I also wanted to lay some foundation for MS Query a very underutilized feature in Excel IMHO. I’ll take a look at it a bit more in future post(s).

    That’s it for today. I’m going to watch some Stooges – nyuk..nyuk..nyuk.

    Downloads

    Download the Access Database or the Excel Workbook from here on OneDrive.

    Additional Resource

    1. Contextures
    2. Excel User
, ,