Excel Back In Black

No, not the classic rock album by the boys from AC/DC – Excel has a new black theme, and with a registry hack, you can give the Visual Basic Editor a black background – let’s take a look.

Office 365 Pro Plus Update

The Black Theme is only available for subscribers of Office 365. I’m using Office 365 Pro Plus and I had to jump through a few hoops to get the new black theme as well as the 6 new functions recently released for Excel:


  • Textjoin()
  • Concat()
  • Maxifs()
  • Minifs()
  • Ifs()
  • Switch()

I followed the steps listed on this site to set myself up for First Release through the Office 365 Admin Center. However, after 24 hours, I did not have the updates. I uninstalled Office 365 and reinstalled and voila! – update successful!

Office 365 Black Theme

To change the Office Theme:

ClickFileMenu

Click on the File Menu

OfficeAccount

Click on Account

OfficeTheme

Click on the Office Theme you like – I’m trying out the Black Theme. Giving a black background to the Visual Basic Editor is not as straight forward – it will require a bit of VBA with a registry hack.

VBE Black Background

The code below was posted by Belleye on reddit. You can see the original post here

Backup The Widows Registry

Below is some code that is changing Windows Registry settings. Before I start mucking around with the Registry, I’m going to create a backup in case things go awry.

Sub BackupRegistry()
'==========================================================================================================
'Author        : Belleye
'Link          : http://bit.ly/1Vkw8xg
'Modified by   : ws
'Backs up the VBA registry keys to C:\
'RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.0\Common\" ' Windows 10 Excel 2010
'RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common\" ' Windows 10 Office365 Pro Plus
'==========================================================================================================
    
Dim wsh As Object
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim RegPath As String
Dim BackupFile As String

Set wsh = VBA.CreateObject("WScript.Shell")
    
' User defined variables
    RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common\" ' Windows 10 Office365 Pro Plus
    BackupFile = "C:\VBA_" & Format(Now, "yyyymmddhhmmss") & ".reg"

    wsh.Run "regedit.exe /e " & Chr(34) & BackupFile & Chr(34) & " " & Chr(34) & RegPath & Chr(34), windowStyle, waitOnReturn ' Export the registry key
    wsh.Run "Notepad.exe " & BackupFile ' Open backup in Notepad to show the key has been backed up

End Sub

Display Current VBE Colors

First, let’s look at the current color setting for the VBE:

Sub DisplayVBEColors()

'Exports the VBA editors colour scheme to the Immediate Window
'RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.0\Common\" ' Windows 10 Excel 2010
'RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common\" ' Windows 10 Office365 Pro Plus

Dim myWS As Object
Dim RegPath As String

Set myWS = CreateObject("WScript.Shell")
RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common\" ' Windows 10 Excel 2010

Debug.Print "ForeG = " & Chr(34) & myWS.RegRead(RegPath & "CodeForeColors") & Chr(34)
Debug.Print "BackG = " & Chr(34) & myWS.RegRead(RegPath & "CodeBackColors") & Chr(34)

End Sub

Results :

ForeG = “0 0 5 0 1 6 14 0 0 0 0 0 0 0 0 0 ”
BackG = “0 0 0 7 6 0 0 0 0 0 0 0 0 0 0 0 “

I’ll see if I can find the same information by navigating through the Registry Editor:

Registry

Looks good. Those are the settings to use if I want a white background and black text in the foreground.

VBEWhite

Next, I’ll set the VBE background to black

Change the VBE Background To Black

Sub SetVBEBackgroundToBlack()
'==========================================================================================================
'Author        : Belleye
'Link          : http://bit.ly/1Vkw8xg
'Modified by   : ws
'Comments      :
'              : RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.0\Common\" ' Windows 10 Excel 2010
'              : RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common\" ' Windows 10 Office365 Pro Plus
'              : Changes the VBA colour scheme according to the variables Foreg and BackG
'              : Requires Excel to be restarted
'==========================================================================================================

    Dim wsh As Object
    Set wsh = VBA.CreateObject("WScript.Shell")
    Dim waitOnReturn As Boolean: waitOnReturn = True
    Dim windowStyle As Integer: windowStyle = 1
    Dim RegPath As String
    Dim ForeG As String
    Dim BackG As String

    ' User defined variables
    RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common" ' Windows 10 Office365 Pro Plus no \ on the end

    ' Customise your colours here
    ForeG = "2 4 5 0 1 15 11 10 4 8 0 0 0 0 0 0 "
    BackG = "4 7 6 7 6 4 4 4 1 4 0 0 0 0 0 0 "

    wsh.Run "reg add " & RegPath & " /t REG_SZ /v CodeForeColors /d " & Chr(34) & ForeG & Chr(34) & " /f", windowStyle, waitOnReturn
    wsh.Run "reg add " & RegPath & " /t REG_SZ /v CodeBackColors /d " & Chr(34) & BackG & Chr(34) & " /f", windowStyle, waitOnReturn

End Sub

VBEBlack

Tidy Up

I have to admit – I’m not a fan. I switched back to the white background. But if that is your thing – go for it.

, , , , ,

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

, , , , , , ,

SparkHeaderFinal

A sparkline is a small intense, simple, word-sized graphic with typographic resolution. – Edward Tufte

Today, I’ll look at how I might be able to :

  • Dynamically find a Range of data by finding the first and last Cells of data
  • Add a SparkLine Group for the data Range
  • Format the Sparklines and add markers for various SparkPoints
  • Add appropriate SparkAxes to be used as reference lines for visualizing actual values vs target values

 

The Data

First, I’ll need some data. I’d like some QA data for some Reps for each month of 2014. 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.

SparklineData3

Here is the final data summarized by Rep and by Month:

SparklineData4

Delete Existing SparkLine Groups

First, I’ll need to delete any existing SparkLine Groups from previous runs:

Option Explicit

Public Sub DeleteSparklines(ws As Worksheet)

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'DeleteSparklines
    'Deletes any Sparkline Groups from the specified worksheet
    '
    'Parameters        :
    'ws                :   Required, A Woksheet Object.
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Declare objects
        Dim rng As Range
        Dim sg As SparklineGroup

    'Error handler
        On Error Resume Next

    'Initialize
        Set rng = ws.UsedRange

    'Delete Sparkline Groups if any exist
        With rng
            For Each sg In rng.SparklineGroups
                sg.Delete
            Next sg
        End With

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Delete SparkLine Group", Err.HelpFile, Err.HelpContext
        Err.Clear

    'Tidy up
        Set rng = Nothing
End Sub

Find Last Cell With Data

Next, I’ll need to find the last cell with data on the worksheet:

Public Function GetLastCell(ws As Worksheet, _
                            rngBegin As Range) As Range

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetLastCell
    'Returns a Range Object as a Cell.
    '
    'Parameters        :
    'ws                :   Required, A Woksheet Object.
    'rng               :   Required, A Range Object.
    '                      Use xlPrevious when searching for the last used Cell.
    '                      Use xlNext when searching or the first used cell.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Declare objects
        Dim rng As Range

    'Get range as a single cell
        With ws
            Set rng = .Cells.Find(What:="*", _
                                  After:=rngBegin, _
                                  LookIn:=xlFormulas, _
                                  LookAt:=xlPart, _
                                  SearchOrder:=xlByRows, _
                                  SearchDirection:=xlPrevious, _
                                  MatchCase:=False)
        End With

    'Pass the range to the function
        Set GetLastCell = rng

    'Tidy up
        Set rng = Nothing

End Function

Find First Cell With Data

Now that I have the last cell with data, I can find the first cell with data. Note in the function below, I added a third parameter to include labels or not:

SparkLineRemoveLabels

Public Function GetFirstCell(ws As Worksheet, _
                             rngBegin As Range, _
                             IncludeLabels As Long) As Range

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetFirstCell
    'Returns a Range Object as a Cell.
    '
    'Parameters        :
    'ws                :   Required, A Woksheet Object.
    'rng               :   Required, A Range Object.
    '                      Use xlPrevious when searching for the last used Cell.
    '                      Use xlNext when searching or the first used cell.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Declare objects
        Dim rng As Range

    'Declare variables
        Dim r As Long
        Dim c As Long

    'Get range as a single cell
        With ws
            Set rng = .Cells.Find(What:="*", _
                                  After:=rngBegin, _
                                  LookIn:=xlFormulas, _
                                  LookAt:=xlPart, _
                                  SearchOrder:=xlByRows, _
                                  SearchDirection:=xlNext, _
                                  MatchCase:=False)
        End With

    'Remove row and column labels if needed
        Select Case IncludeLabels
            Case 2                          'Do not include labels
                With rng
                    r = .Row + 1
                    c = .Column + 1
                End With

                With ws
                    Set rng = .Cells(r, c)
                End With
            Case Else
                'Do nothing
        End Select

    'Pass the range to the function
        Set GetFirstCell = rng

    'Tidy up
        Set rng = Nothing

End Function

Create A Range For The Data Source

Next, I’ll create a Range to be used as the data source for the SparkLine Group using the last cell and the first cell on the worksheet:

Set rngSparkLineSource = ws.Range(firstcell, lastcell)

Create A Range For The SparkLine Group

Now that I have the first and last cell of the data source Range, I can create a Range for the SparkLine Group:

 lngSparkLineColumn = lastcell.Column + 1                                    'Move to next blank column
        lngSparkLineLastRow = lastcell.Row
        lngSparkLineFirstRow = firstcell.Row
        With ws
            Set rngSparkLineDestination = .Range(.Cells(lngSparkLineFirstRow, lngSparkLineColumn), _
                                                 .Cells(lngSparkLineLastRow, lngSparkLineColumn))
         End With

Create The SparkLine Group

One of the required parameters of the SparkLine Group Object is source data as a string. I have the source data as a Range, so I need to create a string from the Range in the form of Worksheet!Range.Address:

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

SparkLineGroup2

SparkLine Group Formatting

Everything is looking great so far! Next, I would like to add a little formatting to the SparkLine Group. In the Sub I created, I set the default visibility for Highpoint, Lowpoint and EndPoint to true, but I can easily change to false when I call the Sub. I’ll leave the default values for now:

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

SparkLineGroupFormatted2

Looks better! I tried the line weight at 1.5 and thought it was too thick and made the Low, High and Endpoint Markers disappear, so I settled on a line weight of 1.3.

Horizontal Axis As A Reference Line

The Sparklines look good, but we can make them better by adding a reference line to compare actual values vs a target. To dynamically add a Horizontal Axis as a Reference Line, I’ll need to do a few things:

  • Add a Worksheet to hold all calculations for the Horizontal Axis
  • Determine the size of the range of the source data
  • Create a Range on the new Worksheet the same size as the source Range
  • Add a formula to the new Range to calculate the difference between actual and target values
  • Use the resultant Range as the source Range for the SparkLine Group
  • Determine the appropriate vertical scale

Add A Workshsheet

I’ll add a Worksheet and name it “SparklineData”. Before I can create the Worksheet, I need to check if it already exists. If it does exist, delete it and then add it:

 'Check if a worksheet named "SparklineData" already exists, if it does, delete it
        With wb
            For Each sh In .Worksheets
                If sh.Name = "SparklineData" Then sh.Delete
            Next sh
        End With

    'Add a worksheet for horizontal axis value calculations
        Call AddWorksheet(wb:=wb, _
                          strSheetName:="SparklineData")
        Set wsSparklineData = wb.Worksheets("SparklineData")

The Sub:

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
            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

Create A Range To Contain Calculations

Now that I have a Worksheet, I need to add a Range to hold calculations that are the difference of my target value less actual performance. I want the Range to begin in the same cell and contain the same number of Rows and Columns as the Range that contains my actual values:

'Create a Range on the Sparkline Data Worksheet
    'The Range should be the same size as the Source Data Range
        With rngSparkLineSource
            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 Calculate Variance: Target Vs Actual

Now that I have a Range, I need to add a formula to each Cell in the Range to calculate the the variance between target and actual values:

    '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 = rngSparkLineSource.Cells(i, j).Value - lngTARGET
            Next i
        Next j

Use Variance Calculations As Data Source For SparkLine Group

Now, that I have calculated variances (Target – Actual) I’ll use the resultant Range as the data source for the Sparkline Group. See the GetSparkLineGroup Function above. Take note that I am using the variance calculations as the source for the SparkLine Group, but the Sparklines are being presented next to the Actual values:

    'Add SparkLine Group
        Set slg = GetSparkLineGroup(rngSparkLinePlacement:=rngSparkLineDestination, _
                                    rngSparkLineSourceData:=rngAxis)

Add Sparkline Axes As A Horizontal Reference Line

Lastly, I would like to add a Horizontal Axis as a reference line to compare actual values to a target value. The money shot here is if all values are below the target value or if all values are above the target value – in both cases, the Vertical Axis requires a Custom Scale Value. In the code below, I loop through the columns in each row and compare the value to the target value and increment counters depending if the value is greater or less than target. Finally I determine if the lesser or greater count is equal to the number of columns in the row and set the vertical axis accordingly:

Option Explicit

Public Sub FormatSparklineAxes(ws As Worksheet, _
                               rngSparkLineGroup As Range, _
                               rngSparkLineSourceData As Range, _
                               lngValueForComparison As Long, _
                               lngColorHorizontalAxis As Long, _
                               Optional ByVal blnVisHorizontalAxis As Boolean = True)

    'rngSparkLineGroup contains a sparkline group
    'rngSparkLineSourceData contains the data that will be compared to the target value
    'Value for comparison will be used to compare

    'Declare variables
        Dim i As Long                               'Loop through data source rows
        Dim j As Long                               'Loop through data source columns
        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

    'Declare objects
        Dim rngRegroupSparklines As Range
        Dim sg As SparklineGroup

    'Error handler
        On Error GoTo ErrHandler

    'Initialize objects and variables
        lngColumnsDataSource = rngSparkLineSourceData.Columns.Count
        i = 1

    'Ungroup sparklines
        rngSparkLineGroup.SparklineGroups.Ungroup

    'Determine vertical axis placement for each sparkline
        For Each sg In rngSparkLineGroup.SparklineGroups
            i = sg.Location.Row
            lngValueLesser = 0
            lngValueGreater = 0
            For j = 1 To rngSparkLineSourceData.Columns.Count
                If ws.Cells(i, j + 1).Value < lngValueForComparison Then
                    lngValueLesser = lngValueLesser + 1
                ElseIf rngSparkLineSourceData.Cells(i, j + 1).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

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Format sparkline axes", Err.HelpFile, Err.HelpContext
        Err.Clear

End Sub

SparklinesFinal2

The Main Sub()

Here is the main Sub() that calls all other Subs() and Functions():

Option Explicit

Sub CreateSparkLines()

    'Declare objects
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim sh As Worksheet
        Dim wsSparklineData As Worksheet
        Dim slg As SparklineGroup
        Dim rngSparkLineSource As Range
        Dim rngSparkLineDestination As Range
        Dim lastcell As Range
        Dim firstcell As Range
        Dim rngData As Range

    'Declare variables
        Dim lngSparkLineColumn As Long
        Dim lngSparkLineFirstRow As Long
        Dim lngSparkLineLastRow As Long
        Dim RowHeader 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

    'Declare constants
        Const lngTARGET As Long = 98
        Const lngTargetAxis As Long = 0

    'Excel environment
        With Application
            .DisplayAlerts = False
        End With

    'Initialize objects and variables
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets(1)

    'If any previous Sparkline Groups - delete them
        Call DeleteSparklines(ws:=ws)

    'Create a Range Object as the source for the Sparkline Group
        On Error Resume Next
        Set lastcell = GetLastCell(ws:=ws, _
                                   rngBegin:=ws.Cells(1, 1))

        If Not lastcell Is Nothing Then
            Set firstcell = GetFirstCell(ws:=ws, _
                                         rngBegin:=lastcell, _
                                         IncludeLabels:=xlNo)

            Set rngSparkLineSource = ws.Range(firstcell, lastcell)
        Else
            MsgBox "No data exists on the selected sheet"
            Err.Raise 513
        End If

    'Create a Range Object as the destination for the Sparkline Group
        lngSparkLineColumn = lastcell.Column + 1
        lngSparkLineLastRow = lastcell.Row
        lngSparkLineFirstRow = firstcell.Row
        With ws
            Set rngSparkLineDestination = .Range(.Cells(lngSparkLineFirstRow, lngSparkLineColumn), _
                                                 .Cells(lngSparkLineLastRow, lngSparkLineColumn))
         End With

    'Add header
        RowHeader = rngSparkLineDestination.Row - 1
        ws.Cells(RowHeader, lngSparkLineColumn).Value = "Trend"

    'Check if a worksheet named "SparklineData" already exists, if it does, delete it
        With wb
            For Each sh In .Worksheets
                If sh.Name = "SparklineData" Then sh.Delete
            Next sh
        End With

    'Add a worksheet for horizontal axis value calculations
        Call 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 rngSparkLineSource
            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 = rngSparkLineSource.Cells(i, j).Value - lngTARGET
            Next i
        Next j

    'Add SparkLine Group
        Set slg = GetSparkLineGroup(rngSparkLinePlacement:=rngSparkLineDestination, _
                                    rngSparkLineSourceData:=rngData)

    'Format SparkLine Group
        Call 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
        Call FormatSparklineAxes(ws:=wsSparklineData, _
                                 rngSparkLineGroup:=rngSparkLineDestination, _
                                 rngSparkLineSourceData:=rngData, _
                                 lngValueForComparison:=lngTargetAxis, _
                                 lngColorHorizontalAxis:=RGB(217, 217, 217))

    'Return focus to the report
        ws.Activate

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Create Sparkline Group", Err.HelpFile, Err.HelpContext
        Err.Clear

    'Tidy up
        Set lastcell = Nothing
        Set firstcell = Nothing
        Set rngSparkLineSource = Nothing
        Set rngSparkLineDestination = Nothing
        Set slg = Nothing
        Set ws = Nothing
        Set wsSparklineData = Nothing
        Set wb = Nothing

        With Application
            .DisplayAlerts = True
        End With

End Sub

Excel Sparkline Improvements Are Needed

I like sparklines, they are excellent in dashboards when screen real estate is a premium. They are also excellent for exploratory data analysis. But there is room for improvement:

  • Horizontal Axis Range I would like the reference line to have a minimum and maximum range option. For example, for purposes of this post, I used a target value of 98 and a thin grey line was plotted for each sparkline based on the actual values for each data source row. But many times, we would like to view actual QA values against a scale, say 97-98 for example.
  • Spark Markers More options are needed for formatting Spark Markers for beginning, ending, high and low data points. We need to be able to use different shapes and sizes. In the current implementation, the Spark Markers are a bit hard to visualize.

Downloads

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

DownloadSparklines

  • M_CreateSparklines.bas
  • M_FormatSparklineAxes.bas
  • M_FormatSparklines.bas
  • M_RangeObject.bas
  • M_SparklinesAdd,bas
  • M_SparklinesDelete.bas
  • M_Worksheet.bas

Additional Resources – Sparklines

Tidy Up

This post was about using VBA to:

  • 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

In my next post on Sparklines, I will look at how we might use Sparklines with Pivot Tables…stay tuned.

, , , , ,

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!

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

LawnMower_2

Ahhh, mowing the lawn. Going to William’s 66 to buy some fuel. The smell of the gas, the fresh cut grass, fighting the fly-wheel, trying to get perfectly straight lines, rushing to beat the encroaching summer storm, getting a little too close to mom’s peonies – oops!

I traded a mix of Bluegrass, Rye and Fescue of the Midwest a long time ago for the rusty reddish brown that dominates the landscape of the American Southwest. Still, at times, it is great to remember simpler days.

Today’s post, however, is not about how to maintain a 4-Cycle Briggs & Stratton engine. Rather, it is about how to push reporting to Excel.

The Debate

Push to Excel or Pull to Excel? I go back and forth. For me, it depends on my end in mind. If I am completing a corporate model/template – I am more likely to pull data into Excel from other Excel workbooks or various databases. However, if I am creating reports – especially ad hoc – then pushing to Excel might make more sense. Let’s take a look.

Is Excel Running Or Create A New Instance Of Excel

The first thing I want to do, is determine if Excel is running. If Excel is running, use the current instance of Excel, otherwise, create a new instance of Excel.

Option Explicit

Public Function GetXlApp() As Excel.Application

    'Declare objects
        Dim App As Excel.Application

    'Check if Excel is running
        On Error Resume Next
        Set App = GetObject(, "Excel.Application")
        On Error GoTo 0

    'Create Excel if it is not already running
        If App Is Nothing Then
            Set App = CreateObject("Excel.Application")
        End If

    'Pass object to function
        Set GetXlApp = App

    'Tidy up
        Set App = Nothing

End Function

Create Workbook

Now that I have an instance of Excel, I need to add a new Workbook and Worksheet to the instance of Excel

    'Add workbook object
        Set xlBook = xlApp.Workbooks.Add

    'Create worksheet object
        Set xlSheet = xlBook.Worksheets(1)

Excel New Instance

So far, I have created an instance of Excel and added a Workbook and Worksheet to that instance.

Transfer Data From Source To Destination

Now that I have a new instance of Excel and a workbook and worksheet in that instance, I can transfer the data from my source workbook to he new workbook

    'Get rows and columns of region
        With rngCurrent
            rngRows = .Rows.Count
            rngCols = .Columns.Count
        End With

    'Resize destination range
        With xlSheet
            Set xlRange = .Range("A1")
            Set xlRange = xlRange.Resize(rngRows, rngCols)
        End With

    'Transfer range values
        xlRange.Value = rngCurrent.Value

Excel New Instance_2

The data has been transferred from the source workbook to the new workbook. Note how I use rngNew.value = rngOld.value so I do not rely on copy/paste using the Windows Clipboard.

Add A ListObject To The New Range

I’m a huge fan of ListObject Objects (a.k.a. Excel Tables) Are you? Why or why not? Let’s add one to the new workbook to the range of data just transferred.

    'Add a listobject
        Set xlListObject = GetListObject(ws:=xlSheet)

Option Explicit

Public Function GetListObject(ws As Worksheet)

    'Declare objects
        Dim rng As Range
        Dim C As Range
        Dim lo As ListObject

    '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:=xlSrcRange, _
                        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

Excel New Instance_3
A ListObject Object (Excel Table) has been added, I chose to place it exactly where the Range existed previously, I could have put it anywhere. However, since the Range Object and the ListObject Object contain the same data, why keep both? I now have a ListObject which will automatically expand in case someone decides to add additional information after the data was pushed from an external data source.

Add a Pivot Cache

To add a Pivot Table, I need a Pivot Cache. I’ll use the Excel Table as the data source for the Pivot Cache.

    'Add a pivot cache
        Set xlPivotCache = GetPivotCache(wb:=xlBook, _
                                         lo:=xlListObject)

Public Function GetPivotCache(wb As Workbook, _
                              lo As ListObject)

    'Declare Objects
        Dim pc As PivotCache

    'Declare variables
        Dim strPivotCacheSource As String

    'Error handler
        On Error GoTo ErrHandler

    'Pivot cache source
        strPivotCacheSource = lo.Parent.Name & "!" & _
                                lo.Range.Address(ReferenceStyle:=xlR1C1)

    'Create pivot cache
        Set pc = wb.PivotCaches.Create( _
                        SourceType:=xlDatabase, _
                        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

    'Add a sheet for the pivot table
        Set xlSheetReport = AddWorksheet(wb:=xlBook, _
                                         strSheetName:="rpt")

Public Function AddWorksheet(wb As Workbook, _
                             strSheetName As String) As Worksheet

    'Declare variables
        Dim ws As Worksheet
        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

Excel New Instance_4
I now have a new Worksheet to hold the Pivot Table.

Add a Pivot Table

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

    'Add a pivot table
        Set xlPivotTable = GetPivotTable(pc:=xlPivotCache, _
                                         ws:=xlSheetReport, _
                                         strPivotTableName:="PivotTable1")

Public Function GetPivotTable(pc As PivotCache, _
                              ws As Worksheet, _
                              strPivotTableName As String, _
                              Optional ByVal lngRowPlacement As Long = 3, _
                              Optional ByVal lngColPlacement As Long = 3)

    'Declare Objects
        Dim pt As PivotTable
        Dim rng As Range

    '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:=xlR1C1)

    '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

Excel New Instance_5
Now that I have a Pivot Table, I can add Pivot Fields.

Add Pivot Fields To Pivot Table

Now that I have a Pivot Table, I need to specify which fields to use from the Excel Table and their Orientation and Order in the Pivot Table:

Private Sub AddFieldsToPivot(pt As PivotTable)

    'Error handler
        On Error GoTo ErrHandler

    'Add fields to pivot table
        With pt

            'Row fields
                .PivotFields("Region").Orientation = xlRowField
                .PivotFields("Region").Position = 1

                .PivotFields("Reps").Orientation = xlRowField
                .PivotFields("Reps").Position = 2

            'Column fields
                .PivotFields("TrxDate").Orientation = xlColumnField
                .PivotFields("TrxDate").Position = 1

            'Value fields
                .AddDataField .PivotFields("Score"), _
                    Caption:="Avgerage of Score", _
                    Function:=xlAverage
        End With

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table fields", Err.HelpFile, Err.HelpContext

End Sub

Excel New Instance_7

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

 


 

    'Get pivot table range to group
        Set xlPivotTableRange = GetPivotTableRange(pt:=xlPivotTable, _
                                                   strRangeType:="PivotItemDataRange", _
                                                   strPivotField:="TrxDate")

Public Function GetPivotTableRange(pt As PivotTable, _
                                   strRangeType As String, _
                                   Optional ByVal strPivotField As String = vbNullString) As Range

    'Pivot field Range type documentation:
    'http://peltiertech.com/referencing-pivot-table-ranges-in-vba/                  <-Jon Peltier

    'String range types:
        'PivotItemDataRange

    'Declare objects
        Dim rng As Range

    '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 Else
                MsgBox "That is not an option"
                Exit Function
        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. Also, note that the Select Case statement is only the beginning of the function that handles one simple case of a special VBA range name. I will revisit this function later and update it with all of the special VBA range names of a Pivot Table as Jon documents on his site.

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

 


 

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

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. Here is the Sub() that I am calling:

Public Sub GroupRange(rng As Range, _
                      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 Range

    '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

Excel New Instance_8

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:

Private Sub FormatPivotField(pt As PivotTable)

    'Declare objects
        Dim pf As PivotField

    '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

Excel New Instance_9_DataField Format
That looks better.

Set The Column Widths

Another way to improve readability of the Pivot Table is to set all columns to a consistent width. I can set the ColumnWidth of a Range Object, so I’ll use the Function I created earlier to get a special VBA range from the Pivot Table. This time I want to use the DataBodyRange, so first I’ll modify my function to add the new Range Type. Here if the modified function:

Public Function GetPivotTableRange(pt As PivotTable, _
                                   strRangeType As String, _
                                   Optional ByVal strPivotField As String = vbNullString) As Range

    '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 Range

    '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"
                Exit Function
        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

And here is the Sub{} that calls the function to set the column width:

Public Sub PivotTableRangeColWidth(pt As PivotTable)

    'Declare objects
        Dim rng As Range

    '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

And the Pivot Table with the DataBodyRange set to a ColumnWidth of 15

Excel New Instance_10_ColumnWidth

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
Sub PushToExcel()

    'Declare objects
        Dim wbCurrent As Workbook
        Dim wsCurrent As Worksheet
        Dim rngCurrent As Range
        Dim rng As Range
        Dim xlPivotTableRange As Range
        Dim xlRange As Range
        Dim xlApp As Object
        Dim xlBook As Object
        Dim xlSheet As Object
        Dim xlSheetReport As Object
        Dim xlListObject As Object
        Dim xlPivotCache As Object
        Dim xlPivotTable As Object

    'Declare variables
        Dim rngRows As Long
        Dim rngCols As Long
        Dim Periods() As Variant

    'Current objects
        Set wbCurrent = ActiveWorkbook
        Set wsCurrent = wbCurrent.ActiveSheet
        Set rngCurrent = wsCurrent.UsedRange

    'Get Excel app
        On Error Resume Next
        Set xlApp = GetXlApp
        If Not xlApp Is Nothing Then
            xlApp.Visible = True
        Else
            MsgBox "The application was not created. Exiting."
            Exit Sub
        End If

    'Add workbook
        Set xlBook = xlApp.Workbooks.Add

    'Create worksheet object
        Set xlSheet = xlBook.Worksheets(1)

    'Get rows and columns of region
        With rngCurrent
            rngRows = .Rows.Count
            rngCols = .Columns.Count
        End With

    'Resize destination range
        With xlSheet
            Set xlRange = .Range("A1")
            Set xlRange = xlRange.Resize(rngRows, rngCols)
        End With

    'Transfer range values
        xlRange.Value = rngCurrent.Value

    'Add a listobject
        Set xlListObject = GetListObject(ws:=xlSheet)

    'Add a pivot cache
        Set xlPivotCache = GetPivotCache(wb:=xlBook, _
                                         lo:=xlListObject)

    'Add a sheet for the pivot table
        Set xlSheetReport = AddWorksheet(wb:=xlBook, _
                                         strSheetName:="rpt")

    'Add a pivot table
        Set xlPivotTable = GetPivotTable(pc:=xlPivotCache, _
                                         ws:=xlSheetReport, _
                                         strPivotTableName:="PivotTable1")

    'Add fields to pivot table
        Call AddFieldsToPivot(pt:=xlPivotTable)

    '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
        Call FormatPivotField(pt:=xlPivotTable)

    'Set column width pivot table data body
        Call PivotTableRangeColWidth(pt:=xlPivotTable)

    'Tidy up
        'Destroy objects
            Set rngCurrent = Nothing
            Set xlRange = Nothing
            Set xlPivotTableRange = Nothing
            Set xlListObject = Nothing
            Set xlPivotCache = Nothing
            Set xlPivotTable = Nothing
            Set wsCurrent = Nothing
            Set xlSheet = Nothing
            Set xlSheetReport = Nothing
            Set xlBook = Nothing
            Set wbCurrent = Nothing
            Set xlApp = 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 workbook and/or the code modules (.bas files) from OneDrive.

  • PushToExcel_20150516_v1.xlsm
  • M_PushToExcel.bas
  • M_Worksheet.bas
  • M_Public.bas
  • M_Pivot.bas
  • M_ListObjects.bas

Excel New Instance_11_Downloads

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

, , , , , , , , ,

NameBadgeArgumentFinal

Being the 2nd in a series of posts on “Names” in Excel.

Excel uses several “Names”. In a previous post, I wrote about Named Formulas. Today, I’ll take a look at Named Arguments.

Named Arguments

Named arguments are that descriptive tags you sometimes see in VBA code snippets. They are not required, hence, “sometimes”. Here’s a sample of a few:

NamedArguments1

In the sample snippet, I created a function to get a Cell as a Range Object from the user at run-time using the Application.InputBox Method. The InputBox Method actually has 1 required parameter and 8 optional parameters – I am only using 3 parameters – 1 required and 2 optional.


    Read more on the Application.InputBox Method here


Named Arguments Are Not Required

As I stated previously, Named Arguments are not required. Here is the Function rewritten without the Named Arguments. I also added a bit of error handling in case the user clicks the cancel button of the InputBox:

Public Function GetSelectedRangeNoNmArgs() As Range

    'Declare variables
        Dim rng                         As Range
    
    'Users - select a cell on a worksheet
        On Error Resume Next
        Set rng = Application.InputBox _
                        ("Please Select Range", _
                         "Range Select", _
                         8)
        If rng Is Nothing Then
            Exit Function
        End If
    
    'Pass the name of the worksheet to the function
        Set GetSelectedRangeNoNmArgs = rng
    
    'Tidy up
        Set rng = Nothing

End Function

Do you see the difference (other than the error handling) ? Here is a comparison of just the 4 lines of the InputBox of both snippets:

'No Named Arguments
Application.InputBox _
                        ("Please Select Range", _
                         "Range Select", _
                         8)

'Even worse - yikes!
Application.InputBox _
                        ("Please Select Range", "Range Select", 8)

'Named Arguments - Best!
Application.InputBox _
                        (Prompt:="Please Select Range", _
                         Title:="Range Select", _
                         Type:=8)

That makes the parameter values a bit more clear, doesn’t it?

Here’s A Dumb Reason

One reason given on MSDN for using Named Arguments is that you can change the order of the parameters to the function. Like this:

'Original parameter order
Application.InputBox _
                        (Prompt:="Please Select Range", _
                         Title:="Range Select", _
                         Type:=8)

'Rearranged parameters
Application.InputBox _
                        (Type:=8, _
                         Prompt:="Please Select Range", _
                         Title:="Range Select")

IMHO, that is a load of hooey. I cannot think of a single valuable reason to do that – can you?

The Real Reason

The real reason to use Named Arguments is that it makes things clearer – they are self-documenting. My example here is a little silly, maybe you are very use to the InputBox Method and you know the order of the parameters and can rattle ’em off in your sleep like I rattle off the batting order of the ’72 Cinci Reds.


    Petition to get Pete Rose reinstated to Major League Baseball here. Pete was one of the greatest to ever play the game.


Tidy Up

I’m sure you can find some Internet Breadcrumbs of mine, where I have not always used Named Arguments. My code and style have evolved and continue to evolve over time. I now always use Named Arguments – I encourage you to do the same.

, , , , , , , ,

PeleFinal

Pele was an amazing soccer (futbol) player. I’m more of an American football fan myself – but I cannot deny the art, grace and class with which Pele played futbol. Pele is pictured here executing a bicycle kick against Belgium in 1968. Maybe what sets Pele and other sports stars apart from the rest is they too begin with the end in mind as suggested by Stephen Covey in The Seven Habits of Highly Effective People.

Today’s post, however, is not about futbol or the latest book being touted by business and leadership pundits. It is about the Goal Seek Method of the Range Object of the Excel Object Model.

Goal Seek

Goal2

Here is a sample formula to calculate Net Sales using 4 inputs: Average Check, Operating Days, Population and Participation. As you see displayed from FORMULATEXT() Function, the 4 inputs are simply multiplied together.


    The FORMULATEXT() function is one of the new functions introduced with Excel 2013. Check them all out here


We can use Goal Seek manually from the Ribbon. In Excel 2013:

Goal3

  1. Click on the Data Tab of the Ribbon
  2. Go to the Data Tools Group
  3. Click on What-If Analysis
  4. Click on Goal Seek

Goal4

I launched Goal Seek. I want to know what participation would need to be to achieve Net Sales of $10K?

Goal5

Holding all other inputs constant, I would need to increase participation from 14.32% to 16.83% to get to $10K in Net Sales. All well and good so far. But what if I need to find values for 12 different months? 52 Weeks? Some other Scenario with 100’s of desired outputs? Time for some VBA!

Goal Seek VBA

Goal6

I cannot find the Goal Seek Method listed as a Member of the Range Class in the Object Explorer in the VBA Editor?


  1. Press [Alt]+[F11] to launch the VBA Editor
  2. Once in the Editor, [F2] to launch the Object Explorer


Hmmm….I’ll check documentation on MSDN:


  1. Object model reference (Excel 2013 developer reference)
  2. Object model reference (Excel 2010 developer reference)
  3. Object model reference (Excel 2003 developer reference) – Compiled Help File


I checked the Developer Reference for Excel 2013 and Excel 2010. I could not find anything on Goal Seek. I downloaded the Excel 2003 Developed Reference as a compiled help file and finally found some documentation on the Goal Seek Method.

Goal7

Goal8

Here’s a quick little snippet I wrote. Even though Goal Seek does not show as a Method of the Range Object in Excel 2013, even though the Goal Seek Method is not documented in the Excel Developer Reference for Excel 2013, it will still work with Excel 2013.

This is not the first time I have seen this. I can’t recall what the last Object and Member were.

Goal Seek Method Requirements

For the Goal Seek Method to work, I must provide the following objects and values:

  1. A Range Object (Cell) that contains a formula
  2. A goal value
  3. And the changing Cell as a Range Object

Well, that makes sense, since the Goal Seek Dialog Box prompted me to manually select or enter those items earlier.

From the requirements list, I see that one strategy would be to use a loop with the .Cells() Property of the Worksheet Object as the Range Objects. With the Cells() Property, I need to pass a Row Index and a Column Index through each iteration of the loop.

The Setup…

Goal9

I added 11 months to the existing data and randomized the participation amounts. Now I would like to find what the participation would need to be for each of the 12 months to increase sales an additional $5K each month.

Goal10

Goal Seek Method…Fixed Range

Here is a basic Goal Seek Snippet that could be used with a fixed Range where the Worksheets and Range Objects are known and do not change:

Option Explicit

Sub SetGoal()

'----------------------------------------------------------------------
'Use Goal Seek Method of the Range Object with a dictator application
'----------------------------------------------------------------------
'Author     : Winston Snyder
'Date       : 3/30/2015
'Website    : http://dataprose.org/
'----------------------------------------------------------------------

    'Declare objects
        Dim wb As Workbook
        Dim ws As Worksheet
  
    'Declare constants
        Const lngROW_SEEK As Long = 4
        Const lngROW_GOAL As Long = 10
        Const lngROW_CHANGE As Long = 5
        Const lngCOL_BEGIN As Long = 6
        Const lngCOL_END As Long = 17
    
    'Declare variables
        Dim i As Long
    
    'Initialize
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("Sheet1")
    
    'Goal Seek
        With ws
            For i = lngCOL_BEGIN To lngCOL_END
                .Cells(lngROW_SEEK, i).GoalSeek _
                    Goal:=.Cells(lngROW_GOAL, i).Value, _
                    ChangingCell:=.Cells(lngROW_CHANGE, i)
            Next i
        End With
    
    'Tidy up
        Set ws = Nothing
        Set wb = Nothing
End Sub

Goal11

My Change Row was Row 5, “Participation”. Participation has been increased to the point needed to drive Net Sales on Row 4 to the target “New Sales” on Row 10.

All well and good, but what if I want to:

  1. Choose a different set of values pre-programmed values for the the Goal?
  2. Choose a different input/driver Row

I will need something a bit more flexible.

Goal Seek Method…Dynamic Options

One way to make the code snippet a bit more flexible, is to use a Type:=8 InputBox. The Type:=8 InputBox allows the user to select a Cell on a Worksheet. I first introduced this concept in this post on the LIKE Operator.


    More on Application.InputBox Method (Excel) here


I’ll create a Function and call it 3 times to prompt the user to select a cell that begins the Range for

  1. The Range that contains the formula that I am seeking a goal for.
  2. The Range that contains the target value
  3. The Range that contains an input that is to be be changed to arrive at the target value
Public Function GetUserCell(strPrompt As String) As Range
 
    'Declare variables
        Dim rng As Range
     
    'Users - select a cell on a worksheet
        Set rng = Application.InputBox( _
                    Prompt:=strPrompt, _
                    Title:="Select a Cell", _
                    Default:=ActiveCell.Address, _
                    Type:=8) 'Range selection
                     
    'Get the parent worksheet of the selected cell
        Set GetUserCell = rng
     
    'Tidy up
        Set rng = Nothing

 End Function

Now I can create a Sub(), call the function 3 times, and load my 5 variables based on the user selections.

The final dynamic Goal Seek Sub():

Option Explicit

Sub SetGoalDynamic()

'----------------------------------------------------------------------
'Use Goal Seek Method of the Range Object allow user to choose cells in range for:
'     The formula to be used in determining a solution
'     The goal value
'     An input cell that will be altered by Goal Seek to arrive at the desired solution
'----------------------------------------------------------------------
'Author     : Winston Snyder
'Date       : 3/30/2015
'Website    : http://dataprose.org/
'----------------------------------------------------------------------

    'Declare objects
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim rngRowSeek As Range
        Dim rngRowGoal As Range
        Dim rngRowChange As Range
  
    'Declare constants
        Const strROW_SEEK As String = "Please select a cell in the row that contains the formula you will use for Goal Seek."
        Const strROW_GOAL As String = "Please select a cell in the row that contains the Goal Value that you are trying to find a solution for."
        Const strROW_CHANGE As String = "Please select a cell in the row that contains an input value for the formula."
    
    'Declare variables
        Dim lngRowSeek As Long
        Dim lngRowGoal As Long
        Dim lngRowChange As Long
        Dim lngColBegin As Long
        Dim lngColEnd As Long
        Dim i As Long
    
    'Initialize
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("Sheet1")
        
    'Get user inputs
        Set rngRowSeek = GetUserCell(strPrompt:=strROW_SEEK)
        Set rngRowGoal = GetUserCell(strPrompt:=strROW_GOAL)
        Set rngRowChange = GetUserCell(strPrompt:=strROW_CHANGE)
        
    'Get variable values from user inputs
        lngRowSeek = rngRowSeek.Row
        lngRowGoal = rngRowGoal.Row
        lngRowChange = rngRowChange.Row
        lngColBegin = rngRowSeek.End(xlToLeft).Column + 1 'Offset for labels
        lngColEnd = rngRowSeek.End(xlToRight).Column
    
    'Goal Seek
        With ws
            For i = lngColBegin To lngColEnd
                .Cells(lngRowSeek, i).GoalSeek _
                    Goal:=.Cells(lngRowGoal, i).Value, _
                    ChangingCell:=.Cells(lngRowChange, i)
            Next i
        End With
    
    'Tidy up
        Set rngRowSeek = Nothing
        Set rngRowGoal = Nothing
        Set rngRowChange = Nothing
        Set ws = Nothing
        Set wb = Nothing
        
End Sub

Tidy Up

That’s it for today, hopefully something helpful for you in this post. I use Goal Seek a bit when forecasting and budgeting and my supervisor asks me for some options to achieve certain desired targets or we get push back upstream.

How do you use Goal Seek?

Btw, as of today, Monday, March 30,2015, the first NFL Preseason game is only 132 days away. Sunday night, August 9, 2015. Hang in there!

, , , , , , , , , ,

NameBadgeFinal

Excel uses several Names. I’ll take a look at a few beginning with Named Formulas. When developing budgets and forecasts, it is convenient to create an annualized amount for various accounts and spread the amount over time in your model whether it be 52 weeks, 12 months, 360 days, whatever your model calls for – generally driven by your domain or sphere of activity.

Named Formulas

Spread1

I have entered a name for my formula in $E$3 and I entered some random values in $F$3:$Q$3 that SUM to 1.

Spread2F

I highlighted the name that I will use for the Named Formula and the 12 random values that I created.

Spread3

I hit [Ctrl]+[Shift]+[F3] on my keyboard and the Create Names From Selection Dialog popped up. The Name for my Named Formula is in the left-most column, so I accepted the default, Create names from values in the: Left Column.

Spread4

I entered the random value of 98,7654.32 in $D$5 and entered the formula: =$D$5*MySpread in $F$5:$Q$5 below my spread technique. You can see that the 98K is allocated properly to each month based on the percentage I entered for each month in the spread technique – that my friends is wicked cool!

Imagine, if this were a 52 week model, I just went from 52 entries to 1. Additionally, I can go back and change my spread technique anytime and any formulas that use that Named Formula will calculate new values – huge time saver!

Business Case

In reality, I would not have Named Formulas on the same worksheet with inputs and analysis – so I’ll separate them.

Spread5

I moved the Named Formula to the Formula Tab. I left the inputs and spread analysis on the Analysis Tab.

Spread7

The spread is working correctly. I added a formula to sum up all cells in the spread less the input value to make sure 100% of the input value has been spread. Looking good!

Storing Fomulas, Constants, Etc…

Recall, I started my Named Formula on cell $E$3. In reality, I normally start such as items in $A of $B, I’ll move the Named Formula to $B.

Spread8

That’s better – but look what happened to my spread:

Spread9

Since the Named Formula and the Analysis are now starting in different Columns, the Analysis formula is not working correctly. I need a better formula that is more flexible and dynamic that can be used anywhere in the model and not return #VALUE! errors.

The INDEX() and COLUMNS() Functions

Spread10

In my new formula, I begin by using the INDEX() Function. As you see in the image, the INDEX() function may have up to 3 arguments,

  1. Array : I’m using the Named Formula as the array
  2. Row Number : I’m using 0 since the Named Formula is really a Vector Array with 1 dimension
  3. Column Number : I’m using the COLUMNS() Function to count the number of Columns I want and passing that number to the function.

Note in the COlUMNS() Function I am using COLUMNS($F1:F1) this will return 1. As I continue to copy the formula to the right the F1 will update to G1, H1 and so forth thus returning 2 and 3 and so forth respectively.

Spread11

I copied my formula to all cells in my Analysis worksheet and everything ties out once again.

Many Named Formulas

Generally, a budget or forecast model is going to need many different Named Formulas to handle many different spreads. Sales, Revenues and Expenses may, and most likely will, behave in many different ways. I may have a depreciation expense that is straight-line for 5 years at the same time that I am opening or closing for the Fall Semester at a university.

You may also use this strategy for quickly changing slight variations of the same spread technique to tweak timing of expenses and the amount that is allocated to each time period. For example, assume you setup 12 different spreads to allocate expenses related to some investment. All 12 may (should) tie-out to allocate 100% of the expense, they just allocate the expense a little bit differently to different time periods.

Spread12

I quickly added 11 more Named Formulas to my workbook. These names have no purpose and are demonstrative only. In reality, your Named Formulas should be well planned and self-documenting – describing to the reader precisely what the intent of the Formula is. Note in the scrren shot that the values in each of the Named Formulas are the same. I just copied down the original values from the first Named Formula.

Spread12

Spread13

I highlighted the list of all of the Named Formulas and named the list, “lstNamedFormulas” because I am creative like that. Normally, I would make this a dynamic Named Range, but that is another topic for another day.

Spread14

I selected a cell on my Analysis worksheet and added some Data Validation to allow only items from the Named Range I just created.

Spread15

Spread16

I updated my Formula one last time to use the INDIRECT() Function to look at the value that the user selected from the Data Validation List and return the name as the Array back to the INDEX() Function. I’m no fan of the INDIRECT() Function and I use it as sparingly as possible – however, it is appropriate in this context.

Tidy Up

That’s it for today. What are your thoughts on Named Formulas? Do you use them in your daily work for other purposes? Do you abuse the INDIRECT() Function? Let us know.

, , ,

Mercury1940Final

I really like a lot of the Custom Hot Rods out there. Among my favorites are the Ford Mercuries that have been chopped with a Photon Laser and lowered. Among the Custom Hot Rod group the preference is for the 1951 Model. But I prefer the 1940 Model shown here with the hood coming to an apex, that awesome grille,split windshield and those enormous swooping fenders. Cars nowadays have by and large lost sight of these awesome design details. I hope to be able to find my own some day that I can restore and customize.

However, today’s post is not about the Ford Mercury or Custom Hot Rods, it’s about Excel Table TableStyles.

I like Excel Tables and Structured References a lot – 2nd only to PivotTables. If I can’t use a PivotTable, I’ll try to use an Excel Table and lastly a conventional cell-based formula. Today, I’ll look at TableStyles and some ideas on how to modify the TableStyles should you desire.

Get Some Data

First, I’ll need some data that I can convert to an Excel Table. To generate test data fast, I use the Random Data Generator Add-in by Dick Kusleika.

ExcelTableRange

Insert Excel Table

Now that I have a Range of data I can insert n Excel Table.

InsertTableFinal

I clicked on some cell in the Range, selected the Insert Menu and clicked on the Table icon in the Tables Group.

CreateTable

The Create Table dialog box pops up dispalying the CurrentRegion based on the cell I selected before I clicked on Insert Table. The check box for Headers defaults to True (checked) the Table includes Headers, so I’ll leave that as is.

ExcelTable1

When I click on a cell inside the Table the Table Tools Menu lights up.

TableToolsMenuFinal

I clicked on the Design Tab immediately below the Table Tools Menu. In the Table Styles Group, I notice that the Style that was applied to my Excel Table has a feint border around it. I hovered on the thumbnail image of the TableStyle and in the resulting Tool Tip discovered that the name of the TableStyle is Table Style Medium 2.

TableStyleMed2Final

TableStyles

TableStyleFlyout

I clicked on the Table Styles flyout to reveal thumbnail images of all of the different TableStyles. I hovered over each thumbnail with my mouse and the Style was applied to my Table offering a preview of what it would look like if I apply the Style – that’s a nice feature.

I discovered that I do not care for most of the Styles in the Table Style Gallery. Table Style Medium 1-14 are OK – chuck the rest.

TableStyles-Customize

Table Style Medium 1-14 are OK – but maybe I can make them a little better with a little customization. To customize an existing TableStyle, I need to duplicate the Style.

TableStyleCustomize



TableStyleModify

In the resulting Modify Table Style Dialog Box, give the copy of the Style you are duplicating a new name. In the screen shot, I am using tsDataProse3 becuase I already have a couple of Custom Styles in the Workbook.

TableStyleCustomGroup

I now have a Custom Group in the Table Style Gallery in addition to the Groupings for Light, Medium and Dark Table Style Collections.

Now that I have a Custom Style – I can change it however I want. As mentioned I like Table Style Medium 2 – but there are a couple of changes I would like.

  • Add thin white borders to interiors left and right for each Field in the Header Row
  • Add thin white borders to interiors left and right for each Row that has a Banded Color

TableStyleModifyHeaderFinal

I right-clicked on my Custom Style, tsDataProse3, selected Modify from the popup menu and selected Header Row in the Table Element ListBox.

Steps to modify the Header Row:

  • Click on the Format Button
  • In the Format Cells Dialog Box click on the Border Tab
  • Click on the desired Line Style
  • On the Border Preview Diagram I clicked on the Vertical Inside Border

Now when I right-click on my Custom Style, tsDataProse3, selected Modify from the popup menu and selected Header Row in the Table Element ListBox – I see a small change in the ElementForatting textual description with the addition of InsideVertical Border.

TableStyleModifyHeaderBorderFinal

Here is the Header Row after formatting the Inside Vertical Border.

TableStyleModifyHeaderInsideVertFin

Next I want to add an Inside Vertical Border to the Banded Rows.

TableStyleNoVerticalBorderFinal

Steps to modify the First Row Strip (Banded Row):

  • Right-click on the thumbnail image of your Custom Table Style
  • On the pop-up menu, click on modify
  • In the Table Element ListBox, click on First Row Stripe
  • Click on the Format Button
  • On he Format Cells Dialog Box, click on the Border Tab
  • Select a color for the border, I chose White, Backgropund 1, Darker 15% (RGB 217,217,217)
  • Click on the middle border in the Preview Diagram
  • Click “OK” 2x

Now I have nice continuous Inside Vertical Borders for all Cells in the Table.

TableStyleVerticalBorderAddedFin

Next Steps…

In my next post, I’ll look at some VBA that we may implement when working with TableStyles.

Tidy up

The changes I made to the existing TableStyle are very subtle. Make no mistake, this is a conscious choice. I don’t like heavy borders and I largely follow the teachings of Stephen Few when it comes to the display of quantitative data. Check out Steve’s stuff on his blog, Perceptual Edge.

Other Excel Table Articles At dataprose.org

Other Excel Table Articles Around The Horn

, , , ,

CharlieBrownFinal

Here in the States – All Hallows’ Eve (Halloween) is quickly approaching. One of my favorite times of the year with leaves changing color, daylight getting shorter, a crispness in the air, football season is in full swing, and the Fall Classic (Major League Baseball) begins in a few weeks.

All Hallows’ Eve is a time for hobgobblery and apparitions of all sorts as with Charlie Brown and the Peanuts gang pictured here. Excel too has a ghost. In this post I’ll take a look at one and how we might put it to rest.

Worksheet UsedRange Property

The Worksheet Object has a UsedRange Property. Normally, we should be able to use this property so that we can quickly identify the entire UsedRange on the Worksheet without having to jump through a lot of hoops.

UsedRange1

Here is a Range of Cells with some data. We can quickly find the address of the UsedRange on the Worksheet:

Option Explicit

Sub GetUsedRangeAddress()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet
    Set rng = ws.UsedRange
    
    Debug.Print rng.Address
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Output:

$A$1:$J$10

Great – that is what I expected. But what happens if I delete some data?

UsedRange…False/Positive

A false positive occurs when we test for data and Excel tells us that there is data when in fact there is not.

UsedRange2

Here is the same data as before, but I deleted the data from Columns $H:$J. Now I’ll respin the code and check results:

$A$1:$J$10

Hmmm…same results – that is not good – therefore:


    we cannot rely on the UsedRange Property of the Worksheet Object. We need a better way to find the TRUE used range of data


The Last Used Cell

We can use the Find Method of the Range Object to get the last cell on the Worksheet that contains any data:

Sub GetLastCell()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet

    With ws
        Set rng = .Cells.Find(What:="*", _
                              After:=.Cells(1, 1), _
                              LookIn:=xlFormulas, _
                              LookAt:=xlPart, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False)
    End With
                                
    Debug.Print rng.Address
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Output:

$G$10

Great – that’s what I was looking for. What happens if there is nothing on the Worksheet? I moved to a new worksheet in the Workbook and tried the code again:

UsedRangeError1

That’s not good. I need to revise my code a bit to handle cases where there is no data on the worksheet:

Sub GetLastCellHandleNoData()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet

    With ws
        Set rng = .Cells.Find(What:="*", _
                              After:=.Cells(1, 1), _
                              LookIn:=xlFormulas, _
                              LookAt:=xlPart, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False)
    End With
    
    If Not rng Is Nothing Then
        Debug.Print rng.Address
    Else
        Debug.Print "There is no data on worksheet ", ws.Name
    End If
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

I tested the code on a Worksheet with data in $A$1:$G$10. Results:

$G$10

Great – that’s what I expected.

Next I tested on a Worksheet with no data. Results:

There is no data on worksheet Sheet2

Great – that’s what I expected.


    I tested the code on a wide variety of scenarios for data placement on the Worksheet. It appears to work for any possible scenario. Please let me know if your tests return unexpected results or errors.


I now have the last used Cell on the Worksheet. Now I need the first used Cell on the Worksheet.

The First Used Cell

For the first used Cell, I tested Cell(1,1) first and then the remainder of the Worksheet. When data was in Cell $A$1, beginning at $A$1 and searching was returning the next Cell address.

Sub GetFirstCell()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet

    With ws
        If Not IsEmpty(ws.Cells(1, 1)) Then
            Set rng = ws.Cells(1, 1)
        Else
            Set rng = .Cells.Find(What:="*", _
                                  After:=.Cells(1, 1), _
                                  LookIn:=xlFormulas, _
                                  LookAt:=xlPart, _
                                  SearchOrder:=xlByRows, _
                                  SearchDirection:=xlNext, _
                                  MatchCase:=False)
        End If
    End With
    
    If Not rng Is Nothing Then
        Debug.Print rng.Address
    Else
        Debug.Print "There is no data on worksheet ", ws.Name
    End If
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Final Functions() and Subs()

The stuff above is fine, but it would be cool if we could develop a function to return the True Used Range. I developed a few Functions() and Subs() to that end.

Function..GetUserSelectedCell

I would like to prompt the user to select a cell and test if there is any data on the worksheets the cell is located on. This makes my code more efficient before I continue processing.

Here I am using the InputBox of the Application Object with Type 8 parameter to allow the user to select a cell for the InputBox. More on the Application.InputBox Method (Excel).

Public Function GetUserSelectedCell(strPrompt As String, _
                                    strTitle As String) As Range

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetUserSelectedCell
    'Returns a Range Object based on Cell user selects
    '
    'Parameters        :
    'strPrompt         :    A string variable.
    '                  :    Provide a question or statement to the user to take some action.
    'strTitle          :    A string variable.
    '                  :    Provide a title for the InputBox.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

     'Declare variables
        Dim rng                         As Range
        
    'Users - select a cell on a worksheet
        On Error Resume Next
        Set rng = Application.InputBox( _
                        Prompt:=strPrompt, _
                        Title:=strTitle, _
                        Default:=ActiveCell.Address, _
                        Type:=8) 'Range selection

        On Error GoTo 0
        
    'Activate the worksheet
        On Error Resume Next
        rng.Parent.Activate
        
    'Pass object to function
        Set GetUserSelectedCell = rng
     
    'Tidy up
        If Not rng Is Nothing Then Set rng = Nothing

 End Function

And here is how I call the Function in the final Sub()

    'Prompt user to select a cell on a worksheet
        Set rngUserCell = GetUserSelectedCell(strPrompt:="Please select a cell on a worksheet.", _
                                              strTitle:="Get Cell Selection From User")

Function..What if the user clicked cancel?

The user may choose to cancel at the InputBox, so we need to handle that possibility. In this Function() I am using a MsgBox to ask the user if they wish to try again. More on the MsgBox Function.

Public Function GetUserMessageResponse(strPrompt As String, _
                                       strTitle As String, _
                                       lngButtons As Long) As Long

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetUserMessageResponse
    'Returns a value as a Long DataType
    '
    'Parameters        :
    'strPrompt         :    Required. A string datatype.
    '                  :    Provide a question or statement to the user to take some action.
    'strTitle          :    A string datatype.
    '                  :    Provide a title for the InputBox.
    'lngButtons        :    A long datatype
    '                  :    Use one of the vba button type enumerations
    '                  :    vbOKOnly            0   OK button only                      <-Default value
    '                  :    vbOKCancel          1   OK and Cancel buttons
    '                  :    vbAbortRetryIgnore  2   Abort, Retry, and Ignore buttons
    '                  :    vbYesNoCancel       3   Yes, No, and Cancel buttons
    '                  :    vbYesNo             4   Yes and No buttons
    '                  :    vbRetryCancel       5   Retry and Cancel buttons
    'Information       :    The Message Box returns 1 of 7 values:
    '                  :    vbOK        1
    '                  :    vbCancel    2
    '                  :    vbAbort     3
    '                  :    vbRetry     4
    '                  :    vbIgnore    5
    '                  :    vbYes       6
    '                  :    vbNo        7
    '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Declare variables
        Dim MsgBoxValue             As Long
     
    'Users - select a cell on a worksheet
        MsgBoxValue = MsgBox( _
                        Prompt:=strPrompt, _
                        Buttons:=lngButtons, _
                        Title:=strTitle)
                        
    'Handle user actions
        If MsgBoxValue <> vbYes Then
            MsgBoxValue = vbCancel
        End If
         
    'Pass value to function
        GetUserMessageResponse = MsgBoxValue

 End Function

Function..TestForData

Now that I have a Cell on a Worksheet, I need to test to see if there is any data on the Worksheet. In the Function below, I first check Cell(1,1) for any data, if that does not contain any data, then I check the rest of the worksheet.

Here I am using the Find Method of the Range Object to search for anything on the Worksheet. More on the Range.Find Method (Excel).

Public Function TestForData(ws As Worksheet) As Boolean

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'TestForData
    'Returns a boolean datatype
    'Checks to see that data exists in at least 1 Cell on a Worksheet
    '
    'Parameters        :
    'ws                :   Required, A Woksheet Object.
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Declare variables
        Dim rng As Range
    
    'Initialize values
        TestForData = False
        
    'Check the worsheet for data
        On Error Resume Next
        If Not IsEmpty(ws.Cells(1, 1)) Then
            Set rng = ws.Cells(1, 1)
        Else
            With ws
                Set rng = .Cells.Find(What:="*", _
                                      After:=.Cells(1, 1), _
                                      LookIn:=xlFormulas, _
                                      LookAt:=xlPart, _
                                      SearchOrder:=xlByRows, _
                                      SearchDirection:=xlPrevious, _
                                      MatchCase:=False)
            End With
        End If
    
    'Update function value if the worksheet contains data
        If Not rng Is Nothing Then TestForData = True
  
    'Tidy up
        Set rng = Nothing

End Function

And here is how I call the Function in the final Sub()

    'Check if the worksheet has any data
        blnFlag = TestForData(ws:=wsUserCell)

Function..Find First And Last Cells

So far, I have tested if the user clicked cancel or if the worksheet contains any data, at this point, I have passed those tests, so now I can get to the meat of it.

I have one Function to return either the first used Cell or the last used Cell – and that my friends is cool. I want my Functions() to be fast, efficient and flexible. I vary whether the Function() returns the last used Cell or first used Cell by passing a variable to the SearchDirection by using the values of the xlSearchDirection Enumeration: xlNext and xlPrevious.

When the SearchDirection is xlNext, the Function() returns the first used Cell. When the SearchDirection is xlPrevious, the Function() returns the last used Cell.

Public Function GetCell(ws As Worksheet, _
                        rng As Range, _
                        lngDirection As Long) As Range
                        
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetCell
    'Returns a Range Object based on a single Cell
    'The Cell is either the first Cell in a Range or the last Cell in a Range
    'The distinction is based on the parameter value passed to lngDirection by the user as either xlPrevious or xlNext
    '
    'Parameters        :
    'ws                :   Required, A Woksheet Object.
    'rng               :   Required, A Range Object.
    'lngDirection      :   Required, Either xlNext or xlPrevious.
    '                      Use xlPrevious when searching for the last used Cell.
    '                      Use xlNext when searching or the first used cell.
    '
    'Use               :   Find the last used Cell first
    '                  :   Pass the last used Cell as a Range Object to the function to determine the first used Cell
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    'Get range as a single cell
        With ws
            Select Case lngDirection
                Case xlNext
                    If Not IsEmpty(.Cells(1, 1)) Then
                        Set rng = .Cells(1, 1)
                    Else
                        Set rng = .Cells.Find(What:="*", _
                                              After:=rng, _
                                              LookIn:=xlFormulas, _
                                              LookAt:=xlPart, _
                                              SearchOrder:=xlByRows, _
                                              SearchDirection:=lngDirection, _
                                              MatchCase:=False)
                    End If
                Case xlPrevious
                    Set rng = .Cells.Find(What:="*", _
                                          After:=rng, _
                                          LookIn:=xlFormulas, _
                                          LookAt:=xlPart, _
                                          SearchOrder:=xlByRows, _
                                          SearchDirection:=lngDirection, _
                                          MatchCase:=False)
            End Select
        End With
        
    'Pass the range to the function
        Set GetCell = rng

    'Tidy up
        Set rng = Nothing

End Function

When I call the Function() to get the last used Cell, I pass Cell(1,1) to the Function() and appropriate enumeration value for SearchDirection:

            'Get last cell
                Set rngLastCell = GetCell(ws:=wsUserCell, _
                                          rng:=wsUserCell.Cells(1, 1), _
                                          lngDirection:=xlPrevious)

When I call the Function() to get the first used Cell, I pass the Range Object created in the first call to the Function() and appropriate enumeration value for SearchDirection:

            'Get first cell
                Set rngFirstCell = GetCell(ws:=wsUserCell, _
                                           rng:=rngLastCell, _
                                           lngDirection:=xlNext)

The Final Sub()…GetTrueUsedRange

And here’s the final Sub() to bring it all together:

Option Explicit
Sub GetTrueUsedRange()

    'Declare variables
        Dim wb As Workbook
        Dim wsUserCell As Worksheet
        Dim rngUserCell As Range
        Dim rngStart As Range
        Dim rngLastCell As Range
        Dim rngFirstCell As Range
        Dim rngTrueUsedRange As Range
        Dim blnDataExists As Boolean
        Dim lngMessageResponse As Long
        Dim lngFirstCellRow As Long
        Dim lngFirstCellColumn As Long
        Dim lngLastCellRow As Long
        Dim lngLastCellColumn As Long
    
    'Initialize
        Set wb = ThisWorkbook
    
    'Prompt user to select a cell on a worksheet
        Set rngUserCell = GetUserSelectedCell( _
                            strPrompt:="Please select a cell on a worksheet.", _
                            strTitle:="Get Cell Selection From User")
                                          
    'Get the worksheet that contains the cell the user selected
        If Not rngUserCell Is Nothing Then
            Set wsUserCell = rngUserCell.Parent
        Else
            lngMessageResponse = GetUserMessageResponse( _
                                    strPrompt:="The selected worksheet does not contain any data." & vbLf & _
                                               "Or you clicked ""Cancel.""" & vbLf & _
                                               "Would you like to try a different worksheet?", _
                                    strTitle:="Missing Data Warning", _
                                    lngButtons:=vbYesNo)
        End If
    
    'Check if the worksheet has any data
        blnDataExists = TestForData(ws:=wsUserCell)
        
    'If the worksheet does not have any data, ask the user to select a different worksheet or exit
        If blnDataExists = False Then
            lngMessageResponse = GetUserMessageResponse( _
                                    strPrompt:="The selected worksheet does not contain any data." & vbCrLf & _
                                               "Would you like to try a different worksheet?", _
                                    strTitle:="Missing Data Warning", _
                                    lngButtons:=vbYesNo)

            If lngMessageResponse = vbYes Then
                Call GetTrueUsedRange   'Recursive call
                Exit Sub
            Else
                MsgBox "You clicked ""No"" or ""Cancel"". Now exiting.", vbInformation, "No Data Warning"
                Exit Sub
            End If
        Else
        
            'Get last cell
                Set rngLastCell = GetCell(ws:=wsUserCell, _
                                          rng:=wsUserCell.Cells(1, 1), _
                                          lngDirection:=xlPrevious)
                With rngLastCell
                    lngLastCellRow = .Row
                    lngLastCellColumn = .Column
                End With
                
            'Get first cell
                Set rngFirstCell = GetCell(ws:=wsUserCell, _
                                           rng:=rngLastCell, _
                                           lngDirection:=xlNext)
                                           
                With rngFirstCell
                    lngFirstCellRow = .Row
                    lngFirstCellColumn = .Column
                End With
        
        End If
        
    'Create true used range
        Set wsUserCell = wb.ActiveSheet
        Debug.Print "Worksheet", wsUserCell.Name
        With wsUserCell
            Set rngTrueUsedRange = .Range(.Cells(lngFirstCellRow, lngFirstCellColumn), _
                                          .Cells(lngLastCellRow, lngLastCellColumn))
        End With
    
    'Results
        Debug.Print "True used range", rngTrueUsedRange.Address

    'Tidy up
        If Not rngUserCell Is Nothing Then Set rngUserCell = Nothing
        If Not rngStart Is Nothing Then Set rngStart = Nothing
        If Not rngLastCell Is Nothing Then Set rngLastCell = Nothing
        If Not rngFirstCell Is Nothing Then Set rngFirstCell = Nothing
        If Not rngTrueUsedRange Is Nothing Then Set rngTrueUsedRange = Nothing
        If Not wsUserCell Is Nothing Then Set wsUserCell = Nothing
        If Not wb Is Nothing Then Set wb = Nothing
End Sub

Tidy Up

I tested the Sub() on several different Worksheets with a variety of placement of data, no data and single cells of data. All tests returned correct expected results. Please let me know if your tests return incorrect results.

How do you find the True Used Range on your Worksheets?

, , , , ,