将每次访问 Table 导出到个人工作簿
Export Each Access Table To Individual Workbook
我一直在使用这种语法，它将数据库中的每个 table 导出到一个 excel 工作簿，但现在我的需要是将每个 table 导出到它自己的工作簿。如何调整它以将每个 table 导出到它自己的工作簿？
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
编辑
我尝试了@HA560 的建议，但得到
的错误
Run-time error '91':
Object variable or With block variable not set
这是更新后的代码：
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
每次使用workbooks.add()方法后...out_file=activeworkbook.path
有点长，其中包括三个程序。在 运行 之后你应该有一个 table 名字的列表和 TRUE/FALSE 在立即 window 说明导出是否成功。
ExportAll - 主程序。
CreateXL - 这将创建 Excel 的实例。它使用后期绑定，因此无需设置引用。
QueryExportToXL - 这是导出 table 的代码。我没有使用 TransferSpreadsheet 因为我喜欢更多的控制。
- 您需要传递对函数的工作sheet引用。
- 您可以将查询名称或记录集传递给函数。
- 您可以传递另一个 sheet 名称。
- 要粘贴的默认单元格是 A1，但您可以更改它。
- 默认情况下，它会调整列宽以适应。
- 您可以传递 collection 个标题名称来代替字段名称。
那里没有太多错误处理 - 例如传递与字段数量不同的标题名称，给出非法的 sheet 名称。
它需要工作:)
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
我一直在使用这种语法，它将数据库中的每个 table 导出到一个 excel 工作簿，但现在我的需要是将每个 table 导出到它自己的工作簿。如何调整它以将每个 table 导出到它自己的工作簿？
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
编辑
我尝试了@HA560 的建议，但得到
Run-time error '91':
Object variable or With block variable not set
这是更新后的代码：
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
每次使用workbooks.add()方法后...out_file=activeworkbook.path
有点长，其中包括三个程序。在 运行 之后你应该有一个 table 名字的列表和 TRUE/FALSE 在立即 window 说明导出是否成功。
ExportAll - 主程序。
CreateXL - 这将创建 Excel 的实例。它使用后期绑定，因此无需设置引用。
QueryExportToXL - 这是导出 table 的代码。我没有使用 TransferSpreadsheet 因为我喜欢更多的控制。
- 您需要传递对函数的工作sheet引用。
- 您可以将查询名称或记录集传递给函数。
- 您可以传递另一个 sheet 名称。
- 要粘贴的默认单元格是 A1，但您可以更改它。
- 默认情况下，它会调整列宽以适应。
- 您可以传递 collection 个标题名称来代替字段名称。
那里没有太多错误处理 - 例如传递与字段数量不同的标题名称，给出非法的 sheet 名称。
它需要工作:)
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