Import data from multiple MS Access tables to MS Excel worksheets 1

[BxWill]

Relatively new to Excel vba and using the code below to import data from multiple MS access 2010 tables into multiple MS Excel worksheets in the same workbook.

The code works but results in quite a few additional worksheets in the MS Excel workbook that are completely blank. Most of the worksheets that are added have "TMP" as part of the name.

I will continue to trouble shoot but definitely appreciate some insight as to the cause of the problem and a resolution!



Thanks in advance.

Option Explicit

' ################################
' The starting point of execution.
' ################################
Sub Main()
    
    ' /* Open the file dialog. */
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = False
        .Title = "Open an Access Database file"
        
        With .Filters
            .Clear
            .Add "Microsoft Access Databases", "*.mdb,*.accdb"
        End With
        
        '/* The user pressed the button .*/
        If .Show = -1 Then
            Dim strAccessPath As String
            
            ' Get the path of the selected file.
            strAccessPath = .SelectedItems(1)
            
            Dim blnGetError As Boolean
            
            ' Call the function to process the selected file.
            blnGetError = TransferAccessToExcel(strAccessPath)
            
            If blnGetError Then
                MsgBox "Runtime error, please check to see if the problems listed below:" & vbNewLine & _
                       "1. ActiveX component (ADO) can't create object;" & vbNewLine & _
                       "2. Provider cannot be found. It may not be properly installed;" & vbNewLine & _
                       "3. The open database has a password.", vbCritical, "Error"
            Else
                MsgBox "Task complete.", vbInformation, "Tips"
            End If
            
        End If
    End With
    
End Sub

' ################################################
' Transfer Access data tables to Excel Worksheets.
' ################################################
Public Function TransferAccessToExcel(ByVal DataSource As String) As Boolean
    
    Dim adoConn         As Object
    Dim rstSchema       As Object
    Dim rstData         As Object
    Dim strConn         As String
    Dim strQuery        As String
    Dim strTable        As String
    Dim strCommonConn   As String
    Dim intK            As Integer
    Dim intCountTables  As Integer
    Dim blnHasError     As Boolean
    Dim qryTable        As QueryTable
    Dim wsDest          As Worksheet
    Dim colTableNames   As New Collection
    
    ' /* Constants for Access database engine. */
    Const A20072010 = "Provider=Microsoft.ACE.OLEDB.12.0;"
    Const A19972003 = "Provider=Microsoft.Jet.OLEDB.4.0;"
    
    blnHasError = False ' The function returns no error.
    strCommonConn = "Persist Security Info=False;Data Source=" & DataSource
    
    ' Set the Access database engine to Access 2007 - 2010.
    strConn = A20072010 & strCommonConn
    
    On Error Resume Next
    
    ' /* Try to create Microsoft ActiveX Data Objects (ADO). */
    Set adoConn = CreateObject("ADODB.Connection")
    Set rstSchema = CreateObject("ADODB.Recordset")
    Set rstData = CreateObject("ADODB.Recordset")
    
    If Err.Number <> 0 Then
        blnHasError = True
        GoTo errExit
    Else
        
        adoConn.Open strConn
        
        If Err.Number <> 0 Then
            Err.Clear
            blnHasError = True
            
            ' Change the Access database engine to Access 1997 - 2003.
            strConn = A19972003 & strCommonConn
            adoConn.Open strConn
             
            If Err.Number <> 0 Then
                blnHasError = True
                GoTo errExit
            Else
                blnHasError = False
            End If
        End If
        
        Set rstSchema = adoConn.OpenSchema(20)  ' adSchemaTables = 20
        
        ' /* Loop to get all the data table names. */
        Do Until rstSchema.EOF
            If rstSchema!TABLE_TYPE <> "ACCESS TABLE" And rstSchema!TABLE_TYPE <> "SYSTEM TABLE" Then
                strTable = rstSchema!TABLE_NAME
                colTableNames.Add strTable
            End If
            
            rstSchema.MoveNext
        Loop
        
        If Not colTableNames Is Nothing Then
            
            intCountTables = colTableNames.Count
            
            '/* Step through each table.*/
            For intK = 1 To intCountTables
                ' Display the progress in the status bar.
                Application.StatusBar = "Importing data table " & CStr(intK) & " of " & CStr(intCountTables)
                
                CloseRst rstData
                
                strQuery = "select * from " & colTableNames(intK)
                
                With rstData
                    .CursorLocation = 3 ' adUseClient = 3
                    .LockType = 3       ' adLockOptimistic = 3
                    .CursorType = 3     ' adOpenStatic = 3
                    .Open strQuery, strConn
                    
                    On Error Resume Next
                    
                    Set wsDest = Worksheets(colTableNames(intK))
                    
                    ' Test if destination sheet exists.
                    If Err <> 0 Then
                        Err.Clear
                        
                        ' Insert a new worksheet after the last worksheet in the active workbook.
                        Sheets.Add After:=Worksheets(Worksheets.Count)
                        ' Rename the added sheet's name as current table's name.
                        ActiveSheet.Name = colTableNames(intK)
                    Else
                        
                        ' Empty cells.
                        wsDest.Cells.Delete xlUp
                        wsDest.Activate
                    End If
                    
                    Set qryTable = ActiveSheet.QueryTables.Add(rstData, Cells(1, 1))
                    
                    ' Show field names from the data source as column headings.
                    qryTable.FieldNames = True
                    qryTable.Refresh
                    ' Don't maintain the connection to the specified data source after the refresh.
                    qryTable.MaintainConnection = False
                    ' Delete the QueryTable object.
                    qryTable.Delete
                End With
            Next
            
            ' Restore the status bar.
            Application.StatusBar = ""
        End If
    End If
    
errExit:
    TransferAccessToExcel = blnHasError
    
    ' /* Close the open recordset to the data tables. */
    CloseRst rstSchema
    CloseRst rstData
    
    ' Close the open connection to the database.
    adoConn.Close
    
    ' /* Release memory. */
    If Not rstSchema Is Nothing Then Set rstSchema = Nothing
    If Not rstData Is Nothing Then Set rstData = Nothing
    If Not adoConn Is Nothing Then Set adoConn = Nothing
    
End Function

' #########################
' Close the open recordset.
' #########################
Public Sub CloseRst(rst As Object)
    If rst.State = 1 Then rst.Close ' adStateOpen = 1
End Sub

 

[PHV]

As a starting point I'd replace this:
colTableNames.Add strTable
with this:
If Not (strTable Like "*TMP*") Then colTableNames.Add strTable

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[BxWill]

I have revised this somewhat.

I have 6 tables in my Access 2010 database that are created via passthrough queries.
Tables are named Current01, Current02, Current03, Prior01, Prior02, Prior03

I am currently creating VBA to transfer the data within the MS Access tables to 6 worksheets
within the MS Excel template workbook on a daily basis. Note, the name of the worksheets are named the same as the MS Access tables.
and each worksheet should be a dynamic range to allow for varying number of records imported.

The end result would be the worksheets within the MS Excel template populated with data.

On a separate worksheet within the same MS Excel template, I plan to use approximately 60 sumproduct formulae to dynamically
populate the cells. Hence, the need for dynamically generating range names of the imported data based on the column headings.

So far, I have the following code but need some additional insight to speed this along.

Ideally, I would like to combine the two sections of code below and accomplish the objective.

 Private Sub ExportExcel()
 
    Dim i As Integer
    Dim myTableName As String
    Dim myExportFileName As String
 
    For i = 1 To 3
        myTableName = "Current" & Format(i, "00")
        myExportFileName = "C:\Users\Test\Documents\CurrentAndPrior" & ".xlsx"
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, myTableName, myExportFileName, True
    Next i
 
	For i = 1 To 3
        myTableName = "Prior" & Format(i, "00")
        myExportFileName = "C:\Users\Test\Documents\CurrentAndPrior" & ".xlsx"
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, myTableName, myExportFileName, True
    Next i
  
End Sub

 Sub DynamicNames()

  Dim LastCol As Long, _
      LabelRow As Long, _
      Col As Long
  Dim sName As String
  Dim c As Range
  Dim Sht As String

  'assign row and column parameters
  '**adjust for the row containing your headings
  LabelRow = 1
  LastCol = Range("IV1").End(xlToLeft).Column

  'grab sheet name
  Sht = "'" & ActiveSheet.Name & "'"

  For Each c In Range(Cells(LabelRow, 1), Cells(LabelRow, LastCol))
    Col = c.Column
    sName = c.Value
    If Len(sName) > 1 Then
      'replace spaces with underscores
      sName = Replace(sName, " ", "_", 1) 
      'create the name
      ActiveWorkbook.Names.Add Name:=sName, RefersToR1C1:= _
        "=OFFSET(" & Sht & "!R2C" & Col & ",0,0,COUNTA(" & Sht & "!C" & Col & ")-1,1)"
    End If
  Next c
End Sub