DustFinal3

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

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

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

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

Data Prep

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

Push2_1

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

Push2_2

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


 

Read more on the DateAdd Function here

 


The SQL View of the Query:

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

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

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

 

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

 


 

Push2_3

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

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

ALTER TABLE tblPushRev
ADD TrxDate Date;

Then I can update the values of TrxDate from NewDate

UPDATE tblPushRev
SET TrxDate = NewDate

And remove the NewDate Field

ALTER TABLE tblPushRev
DROP COLUMN NewDate;

Here’s the revised table:

Push2_4

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

Add A Form

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

frmQueryPicker

I added a blank form and saved it as frmQueryPicker.

Form Properties

PropertySheet

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

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

Add A ListBox

ListBox

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

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

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

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

 

MSysObjects are MS Access System Tables. More on MSysObjects here

 


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

ListBoxWQueries

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

Command Button…Open Query

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

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

CmdQryOpen

Command Button…Cancel

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

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

CmdCancel

CheckBox AutoClose

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

  • Name: chkAutoClose
  • Default Value: True

And the check box label:

  • Name: lblAutoClose
  • Caption: Close after opening Query

frmCheckBox

Code The Form

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

CodeBehind3

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

FormCodeModule

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

Option Explicit

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

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

Cancel Button Click Event:

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

Open Button Click Event:

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

ListBox Double Click Event:

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

FormRun

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

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

BullwinkleFinal2

And Now For Something Completely Different…

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


 

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

  1. Beyond Excel
  2. JP Software Technologies

 


 

Excel Constants

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

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


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

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


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

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

Is Excel Running Or Create Excel

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

Option Explicit

Public Function GetXlApp() As Object

    'Get Excel Application

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

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

Option Explicit

Public Function GetXlWorkbook(xlApp As Object) As Object

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

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

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

Option Explicit

Public Function AddWorksheet(wb As Object, _
                             strSheetName As String) As Object
 
    'Declare variables
        Dim ws As Object
        Dim strMySheetName As String
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Add worksheet
        With wb
            Set ws = .Sheets.Add(After:=.Sheets(wb.Sheets.Count))
            ws.Name = strSheetName
        End With
 
    'Pass object to function
        Set AddWorksheet = ws
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Add a worksheet", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set ws = Nothing
 
End Function

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

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

Transfer Data From DAO Recordset To Excel

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

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

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

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

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

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

QryToExcelRange

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

Add A ListObject To The New Range

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

Option Explicit

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

Add A Pivot Cache

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

Option Explicit

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

Add A Worksheet For The Pivot Table Report

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

Option Explicit

Public Function AddWorksheet(wb As Object, _
                             strSheetName As String) As Object
 
    'Declare variables
        Dim ws As Object
        Dim strMySheetName As String
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Add worksheet
        With wb
            Set ws = .Sheets.Add(After:=.Sheets(wb.Sheets.Count))
            ws.Name = strSheetName
        End With
 
    'Pass object to function
        Set AddWorksheet = ws
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Add a worksheet", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set ws = Nothing
 
End Function

Add A Pivot Table

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

Option Explicit

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

Add Pivot Fields To Pivot Table

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

Option Explicit

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

PivotFields

Group Dates By Month

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

Get A Range From A Pivot Table

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


 

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

 


Option Explicit

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

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

Group Pivot Table Dates

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


 

Read more on the Group Method of the Range Object here

 


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


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

And the Group Range Sub():

Option Explicit

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

GroupDates

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

Format DataFields

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

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

PTFormatNumbers

Set The Column Widths

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

Option Explicit

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

PTColumnWidths

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

The Main Sub()

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

Option Explicit

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

End Sub

Homework

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

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

Downloads

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

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

OneDrive

Additional Pivot Table Resources – Around The Excel Horn

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

Additional Pivot Table Resources – dataprose.org

Some additional resources for working with Pivot Tables on my blog

Tidy Up

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

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

Pre3

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

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

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

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

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


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


TransferSpreadsheet Method

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

tblTeamsPK

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

tblTeamsDesignFieldPropertiesFinal

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

DoCmd.TransferSpreadsheet VBA

Option Compare Database

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

    With DoCmd
        'Turn warnings off
            .SetWarnings False

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

        'Turn warnings on
            .SetWarnings True
            
    End With
    
End Sub

dimTeamsLoadedFinal

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

        'Turn warnings off
            '.SetWarnings False

        'Turn warnings on
            '.SetWarnings True

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

UnableToAppend

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

xlNFLEuropeTeams

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

dimTeamsTableUpdateFinal

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

Make The VBA More Dynamic / Flexible

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

FileDialogFilePicker

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

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

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

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

C:\tmp\xlTeams.xlsx

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

GetSegmentsFromFullFileName

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

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

    'Declare variables
        Dim strSegment As String

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

End Function

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

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

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

GetTableNameFromFileName

Public Function GetTableName(strFile As String) As String

    'Declare variables
        Dim strTable As String

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

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

The function returns :

dimTeams

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

TransferSpreadsheetUsingFunctions

Sub TransferSpreadsheetUsingFunctions()

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

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

dimTeamsLoadFinal

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

Multiple Files…Multiple Tables

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

LoadFilesToTables2

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


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

    1. Beyond Excel
    2. JP Software Technologies


Some New Functions

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

Create FileSystemObject

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

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

File Dialog

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

Public Function GetFDObjectName(strDialogType As String) As String

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

The Final Sub()

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

Option Compare Database

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




Private Sub TransferSpreadsheetRoutine(strFullFileName As String)

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

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

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

End Sub

TablesUpdated

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

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

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

Power Pivot

PowerPivotImport

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

PowerPivotRefresh

Slowly Changing Dimensions (SCD)

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

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

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

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

Tidy Up

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

, , , , , , , ,


Scribe 
 The Microsoft Scripting Runtime Library (scrrun.dll) exposes a couple of objects that we can exploit to increase the power and functionality of VBA.

    Dictionary
    Drive
    FileSystemObject
    TextStream

For today, I’ll look at the FileSystemObject. I’ll take a look at the other objects in future posts.
 
edit: 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 the “Additional Resources” at bottom for links to detailed explanation of Late / Early Binding.
 
I would like a list of all files in a folder, C:\Data. You may use the FileSystemObject to loop through folders and files. In an Excel file, open the Visual Basic Editor, add a module and paste or enter this code:

Option Explicit
Sub Foo()

    'Author: Winston Snyder
    'Date: 11/26/2013
    'Purpose: Demonstrate looping through files in a folder using the FileSystemObject
    'Comment: Uses Late Binding
    '--------------------------------------

    'Declare variables
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim FSO As Object
        Dim fsoFolder As Object
        Dim fsoFile As Object
        Dim strPath As String
        Dim i As Long
        
    'Excel environment - speed things up
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
        End With
        
    'Initialize variables
        strPath = "C:\Data\"
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets.Add(After:=Worksheets(Worksheets.Count))
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set fsoFolder = FSO.GetFolder("C:\Data\")
        i = 2

    'List files in folder
        For Each fsoFile In fsoFolder.Files
            ws.Cells(i, 1).Value = fsoFile.Name
            i = i + 1
        Next fsoFile
    
    'Add Header
        ws.Cells(1, 1).Value = "FileName"
    
    'Tidy up
        'Destroy objects
            Set fsoFolder = Nothing
            Set FSO = Nothing
            Set ws = Nothing
            Set wb = Nothing
        
        'Restore Excel environment
            With Application
                .ScreenUpdating = True
                .DisplayAlerts = True
                .EnableEvents = True
                .Calculation = xlCalculationAutomatic
            End With
End Sub

Ole P. Erlandsen has some nice examples on his site using FileSystemObject to loop through Folders and Subfolders to get all kinds of file information.

A Business Case

OK, we looked at some fairly simple code to use the FileSystemObject (FSO) to look at how to get a list of files in a folder and some of each file’s properties. But how can we use FSO in a business case? Again, I’ll be using Late Binding. Additionally, I’ll be using the DoCmd Object of the Microsoft Access Object Model as well as some VBA functions to look at the file names and manipulate string variables.

My goal is to examine each file in a specified location, if the file meets my criteria, I want to manipulate the name of the file into a table name that I can transfer to MS Access. The code below will append “dim” to the beginning of each file name as well as remove the extension from the file name. I am using “dim” in this case because this is code I use to load dimension (dim) tables to MSAccess and later import into PowerPivot. Without further ado:

Option Compare Database

Public Sub ImportLoadFiles()

    'Author: Winston Snyder
    'Date: 11/27/2013
    'Purpose: Load Excel files to Access database tables
    'Comment: Paste the code into a standard module in the VBE in MS Access
    '----------------------------------------------------
    
    'Declare variables
        Dim strPath As String
        Dim strTableName As String
        Dim FSO As Object
        Dim fsoFolder As Object
        Dim fsoFile As Object
        Dim strFileName As String
        
    'Initialize variables
        strPath = DocsPath & "Load Files\"
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set fsoFolder = FSO.GetFolder(strPath)
        
    'Transfer all Excel files that meet criteria to Access database tables
        With DoCmd
                    
            'Turn off warnings
                .SetWarnings False
                
            'Loop and transfer files to database
                For Each fsoFile In fsoFolder.Files
                    
                    'If Excel file, create a name for  dimension (dim) table
                        If InStr(fsoFile.Name, ".xlsx") Then
                            strFileName = Left(fsoFile.Name, Len(fsoFile.Name) - 5)
                            strFileName = "dim" & strFileName
                            
                            'Transfer the spreadsheet to MS Access table
                                .TransferSpreadsheet TransferType:=acImport, _
                                                     SpreadsheetType:=acSpreadsheetTypeExcel12Xml, _
                                                     TableName:=strFileName, _
                                                     FileName:=strPath & fsoFile.Name, _
                                                     HasFieldNames:=True
                        End If
                Next fsoFile
                
            'Turn on warnings
                .SetWarnings True
        End With
        
    'Tidy up
        'Destroy objects
            Set fsoFolder = Nothing
            Set FSO = Nothing
End Sub

Note the function call on this line

strPath = DocsPath & "Load Files\"

DocsPath is a function, so we’ll need to create a function to return the USERPROFILE of the host machine which we can then use.

Public Function DocsPath() As String
    
    'Purpose: Get the Environ value for User Docuents
    'Returns: C:\Users\%User Name%\Documents\
    
    DocsPath = Environ$("USERPROFILE") + "\Documents\"
End Function

Also, please note, for simplicity I assume the folder, “Load Files” exists in the “ImportLoadFiles” snippet above. If it does not, the code will generate an error. You can make the code more robust by adding some error handling to check if folders exist and if the folder contains files that you are interested in.

An Example

ExcelToAccess

Create Load File

I need to create a load file and I have a process to do that, but I will not go too far into it in this post – I’ll review the process in a future post. For now, two things are important.

  1. The name of the file must be similar to the name of the target table
  2. The column headers in the load file must match the field names in the target table
File Name

The code above takes care of the file to table naming. Recall – the code trims the file extension and appends “dim” to the front of the file name. Therefore, the filename, “Teams.xlsx” is translated to “dimTeams” which is the name of the target table. You just need to plan your load file names to align in some fashion with the name of the target table in the Access database.

Create Access Table

Field (Column) Names

ColumnFieldName

  1. Add a table to your database
  2. Save the table as “dim” and some descriptive name such as “dimTeam”
  3. Name the first field of the table with a descriptive term plus the suffix “Key”. For example, “TeamKey”
  4. Add another field. Give it a descriptive name that describes what the field will contain such as “TeamName”.
  5. Set the Data Type to the appropriate type such as “Short Text”.
  6. While still selected on the second field, click on “Indexed” in the Field Properties pane. Click on the drop-down, change from the default value of “No” to “Yes (No Duplicates)”.
  7. Save and close the table
  8. Run the “ImportLoadFiles” process to load the table from the Excel file.

In my sample of NFL teams, I loaded 32 records in my first pass as expected. I then deleted 4 records from the table, and deleted all but the same 4 teams plus one extra from the load file. I saved the load file and ran the import process. The 4 missing records were imported as expected. the 5th record was already in the table so it was disregarded by Access.

Additional Resources

Tidy up

    Final Thoughts

    The one load file, one Access table, 32 records is a silly example. But what if you have 10 tables…20…50? Now, hopefully, you see the true value. How do you use FileSystemObject (FSO) in your Excel / Access projects? Let us know in the comments section.

    Downloads

    Download the Excel file and Access database from SkyDrive.

, , ,