Экспорт каждой таблицы доступа в отдельную рабочую книгу

Question

Я использую этот синтаксис, который будет экспортировать каждую таблицу в базу данных в рабочую книгу ONE, но теперь мне нужно экспортировать каждую таблицу в свою собственную книгу. Как это можно настроить, чтобы экспортировать каждую таблицу в свою собственную книгу?

Sub ExportToExcel() 
    Dim td As DAO.TableDef, db As DAO.Database 
    Dim out_file As String 

    out_file = "C:\fromaccess.xlsx" 

    Set db = CurrentDb() 
    For Each td in db.TableDefs 
     If Left(td.Name, 4) = "MSys" Then 
     'Do Nothing 
     Else 
     DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, td.Name, out_file, True, Replace(td.Name, "dbo_","") 
     End If 
     Next 
End Sub 

EDIT
Я попытался предложение от @ HA560, но получить ошибку

Ошибка выполнения '91':
переменная объекта или переменная блока не установлен

Этот код обновлен:

Sub ExportToExcel() 
Dim td As DAO.TableDef, db As DAO.Database 
Dim out_file As String 
Dim xl As Excel.Application 

out_file = "C:\fromaccess.xlsx" 

Set db = CurrentDb() 
For Each td in db.TableDefs 
xl.Workbooks.Add 
If Left(td.Name, 4) = "MSys" Then 
    'Do Nothing 
    Else 
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, td.Name, out_file, True, Replace(td.Name, "dbo_","") 
    End If 
    Next 
End Sub 

Answer 1

битого одного длинного, который включает в три процедуры. После запуска вы должны иметь список имен таблиц и TRUE/FALSE в ближайшем окне, указав, был ли экспорт успешным.

ExportAll - Основная процедура.
CreateXL - это создает экземпляр Excel. Он использует последнее связывание, поэтому нет необходимости устанавливать ссылки.

QueryExportToXL - это код для экспорта таблицы. Я не использовал TransferSpreadsheet, поскольку мне больше нравится управление.

• Вам необходимо передать ссылку на листы на эту функцию.
• Вы можете передать либо имя запроса, либо набор записей в функцию.
• Вы можете передать альтернативное название листа.
• Ячейка по умолчанию для вставки - это A1, но вы можете изменить это.
• По умолчанию он настраивает ширину столбцов для соответствия.
• Вы можете передать коллекцию имен заголовков для использования вместо имен полей.

Там не так много ошибок обработки - например, передача другого количества заголовков, чем есть поля, что дает незаконные имена листов.
Она нуждается работа :)

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 

Answer 2

После того, как для каждого использование метода workbooks.add() ... out_file=activeworkbook.path