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!

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