Export All Tables To Seperate XLSX Files

[jo15765]

Access 2013 & Excel 2013 - how can I export each table to it's own worksheet? Meaning let's say for example sake I have 3 tables named - Red, Blue, Green
once this macro is run I need three .xlsx workbooks created called Red.xlsx, Blue.xlsx, Green.xlsx. I tried this example, I found on the internet, but it throws an error for me. Does anyone know how to remedy it or have an alternative solution?

Public Sub ExportAll()


    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim rst As DAO.Recordset
    Dim oXL As Object
    Dim oWrkBk As Object


    Set db = CurrentDb


    'Create instance of Excel.
    Set oXL = CreateXL


    For Each tdf In db.TableDefs
        If Left(tdf.Name, 4) <> "MSys" Then


            'Create workbook with single sheet.
            Set oWrkBk = oXL.WorkBooks.Add(-4167) 'xlWBATWorksheet


            'Open the table recordset.
            Set rst = tdf.OpenRecordset


            'In the immediate window display table name and TRUE/FALSE if exported successfully.
            Debug.Print tdf.Name & " - " & QueryExportToXL(oWrkBk.worksheets(1), , rst, tdf.Name)


            'Save and close the workbook.
            oWrkBk.SaveAs "<path to folder>" & tdf.Name
            oWrkBk.Close


        End If
    Next tdf


End Sub


'----------------------------------------------------------------------------------
' Procedure : CreateXL
' Author    : Darren Bartrup-Cook
' Date      : 02/10/2014
' Purpose   : Creates an instance of Excel and passes the reference back.
'-----------------------------------------------------------------------------------
Public Function CreateXL(Optional bVisible As Boolean = True) As Object


    Dim oTmpXL As Object


    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Defer error trapping in case Excel is not running. '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''
    On Error Resume Next
    Set oTmpXL = GetObject(, "Excel.Application")


    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'If an error occurs then create an instance of Excel. '
    'Reinstate error handling.                            '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo ERROR_HANDLER
        Set oTmpXL = CreateObject("Excel.Application")
    End If


    oTmpXL.Visible = bVisible
    Set CreateXL = oTmpXL


    On Error GoTo 0
    Exit Function


ERROR_HANDLER:
    Select Case Err.Number


        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure CreateXL."
            Err.Clear
    End Select




End Function




'----------------------------------------------------------------------------------
' Procedure : QueryExportToXL
' Author    : Darren Bartrup-Cook
' Date      : 26/08/2014
' Purpose   : Exports a named query or recordset to Excel.
'-----------------------------------------------------------------------------------
Public Function QueryExportToXL(wrkSht As Object, Optional sQueryName As String, _
                                                  Optional rst As DAO.Recordset, _
                                                  Optional SheetName As String, _
                                                  Optional rStartCell As Object, _
                                                  Optional AutoFitCols As Boolean = True, _
                                                  Optional colHeadings As Collection) As Boolean


    Dim db As DAO.Database
    Dim prm As DAO.Parameter
    Dim qdf As DAO.QueryDef
    Dim fld As DAO.Field
    Dim oXLCell As Object
    Dim vHeading As Variant


    On Error GoTo ERROR_HANDLER


    If sQueryName <> "" And rst Is Nothing Then


        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'Open the query recordset.                               '
        'Any parameters in the query need to be evaluated first. '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Set db = CurrentDb
        Set qdf = db.QueryDefs(sQueryName)
        For Each prm In qdf.Parameters
            prm.Value = Eval(prm.Name)
        Next prm
        Set rst = qdf.OpenRecordset
    End If


    If rStartCell Is Nothing Then
        Set rStartCell = wrkSht.cells(1, 1)
    Else
        If rStartCell.Parent.Name <> wrkSht.Name Then
            Err.Raise 4000, , "Incorrect Start Cell parent."
        End If
    End If




    If Not rst.BOF And Not rst.EOF Then
        With wrkSht
            Set oXLCell = rStartCell


            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'Paste the field names from the query into row 1 of the sheet. '
            'Or the alternative field names provided in a collection.      '
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            If colHeadings Is Nothing Then
                For Each fld In rst.Fields
                    oXLCell.Value = fld.Name
                    Set oXLCell = oXLCell.Offset(, 1)
                Next fld
            Else
                For Each vHeading In colHeadings
                    oXLCell.Value = vHeading
                    Set oXLCell = oXLCell.Offset(, 1)
                Next vHeading
            End If


            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'Paste the records from the query into row 2 of the sheet. '
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            Set oXLCell = rStartCell.Offset(1, 0)
            oXLCell.copyfromrecordset rst
            If AutoFitCols Then
                .Columns.Autofit
            End If


            If SheetName <> "" Then
                .Name = SheetName
            End If


            '''''''''''''''''''''''''''''''''''''''''''
            'TO DO: Has recordset imported correctly? '
            '''''''''''''''''''''''''''''''''''''''''''
            QueryExportToXL = True


        End With
    Else


        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'There are no records to export, so the export has failed. '
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        QueryExportToXL = False
    End If


    Set db = Nothing


    On Error GoTo 0
    Exit Function


ERROR_HANDLER:
    Select Case Err.Number


        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure QueryExportToXL."
            Err.Clear
            Resume
    End Select


End Function

[pbaldy]

Hard to remedy an error when you haven't said what it is. You could use TransferSpreadsheet within the TableDef loop.

[JoeM]

Rather than use/create all that code, why not just use TransferSpreadsheet, i.e.

Public Sub ExportAll()


    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim ExportFilePath As String

    Set db = CurrentDb

'   Set Export File Path
    ExportFilePath = "C:\Temp\"

    For Each tdf In db.TableDefs
        If Left(tdf.Name, 4) <> "MSys" Then
            DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, tdf.Name, ExportFilePath & tdf.Name, True
        End If
    Next tdf
    
    MsgBox "Done!"

End Sub

Just change the Export File Path and Excel file type to suit your needs.

[jo15765]

Rather than use/create all that code, why not just use TransferSpreadsheet, i.e.

Public Sub ExportAll()


    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim ExportFilePath As String

    Set db = CurrentDb

'   Set Export File Path
    ExportFilePath = "C:\Temp\"

    For Each tdf In db.TableDefs
        If Left(tdf.Name, 4) <> "MSys" Then
            DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, tdf.Name, ExportFilePath & tdf.Name, True
        End If
    Next tdf
    
    MsgBox "Done!"

End Sub

Just change the Export File Path and Excel file type to suit your needs.

Thank you, this works, but it creates a .xlsb (binary worksheet) as opposed to a .xlsx. What is the diff between them?

[JoeM]

You are welcome!

As I mentioned, you can choose any Excel type that you want.
Here is a listing of options: https://msdn.microsoft.com/en-us/lib.../ff196017.aspx