vba 使用 DoCmd.OutputTo 将 Access 查询导出到多个 Excel 文件

Using DoCmd.OutputTo to export an Access query to multiple Excel files

提问by ZX9

I have a query "myQuery" that returns more than 65,000 records, and as such, cannot be exported to one .xlsx file.

我有一个查询“myQuery”，它返回超过 65,000 条记录，因此无法导出到一个 .xlsx 文件。

I'm attempting to break up this output to multiple files.

我正在尝试将此输出分解为多个文件。

I'm still very much a beginner with VBA, but I've put the following together as best I can from research. This code is intended to iterate through the queried data, then output a new file for each 65,000 records.

我仍然是 VBA 的初学者，但我已经从研究中尽可能地将以下内容放在一起。此代码旨在遍历查询的数据，然后为每 65,000 条记录输出一个新文件。

Private Sub btnfrm1export_Click()

Dim outputFileName As String
Dim dlgOpen As FileDialog
Dim numFiles As Integer
Dim rs As String
Dim numr As Integer
Dim sql As String
Dim rec As Recordset

'Allows user to pick destination for files and gives value to sItem.

Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
    With dlgOpen
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then
        sItem = .SelectedItems(1)
        End If
    End With

'Counts the records in myQuery to give the number of files needed to numFiles, assuming 60,000 records per file.
Set rec = CurrentDb.OpenRecordset("myQuery")
numFiles = Round(rec.RecordCount / 60000, 0)
numr = 1

' Changes the SQL of the query _vba in the current Database to select 60000 records from myQuery
rs = "SELECT TOP 60000 myQuery.* FROM myQuery"
    CurrentDb.QueryDefs("_vba").sql = rs

'Defines SQL for clearing top 60000 (used in the following loop).
sql = "DELETE TOP 60000 myQuery.* FROM myQuery"

'Loops once to create each file needed    
Do While numFiles > 0

'Sets a file name based on the destination folder, the file number numr, and information from a combobutton cbo1 on Form frm1.
    outputFileName = sItem & "\" & Forms!frm1!cbo1 & "_Report_Pt" & numr & "_" & Format(Date, "yyyyMMdd") & ".xlsx"

'Outputs top 60000 of myQuery records to an excel file.
    DoCmd.OutputTo acOutputQuery, "_vba", acFormatXLSX, outputFileName

    numFiles = numFiles - 1
    numr = numr + 1

'Deletes top 60000 from myQuery.
    CurrentDb.Execute sql

Loop

End Sub

However, I'm getting:

但是，我得到：

Run-time error '2302': Microsoft Access can't save the output data to the file you've selected.

运行时错误“2302”：Microsoft Access 无法将输出数据保存到您选择的文件中。

at DoCmd.OutputTo acOutputQuery, "_vba", acFormatXLSX, outputFileName

在 DoCmd.OutputTo acOutputQuery, "_vba", acFormatXLSX, outputFileName

I do need this to be automated in vba and without pop-ups, etc. Any suggestions to make my code more efficient and proper is appreciated, but the REAL question is how to eliminate the error with DoCmd.OutputTo or make this work.

我确实需要在 vba 中自动执行此操作，并且没有弹出窗口等。任何使我的代码更高效和正确的建议都值得赞赏，但真正的问题是如何消除 DoCmd.OutputTo 的错误或使其工作。

Thanks for any and all help!

感谢您的任何帮助！

采纳答案by Wayne G. Dunn

Although the subject line concerns trying to output multiple Excel files, the real issue is trying to create an Excel file from an Access table or query which contains more than 65,000 rows - by using VBA. If VBA is NOT a requirement, then you can export a query or table by right-clicking on the object name, selecting export, then Excel. DO NOT check the box for 'Export data with formatting...' and it will work.

尽管主题行涉及尝试输出多个 Excel 文件，但真正的问题是尝试通过使用 VBA 从包含超过 65,000 行的 Access 表或查询创建 Excel 文件。如果 VBA 不是必需的，那么您可以通过右键单击对象名称，选择导出，然后选择 Excel 来导出查询或表。不要选中“使用格式导出数据...”框，它会起作用。

The code shown below was found at: http://www.myengineeringworld.net/2013/01/export-large-access-tablequery-to-excel.html(Created By Christos Samaras) and will properly export a large table/query to Excel

下面显示的代码位于：http: //www.myengineeringworld.net/2013/01/export-large-access-tablequery-to-excel.html（由 Christos Samaras 创建）并将正确导出大表/查询脱颖而出

Option Compare Database
Option Explicit

Sub Test()  
    'Change the names according to your own needs.
    DataToExcel "Sample_Table", "Optional Workbook Path", "Optional Target Sheet Name"

    'Just showing that the operation finished.
    MsgBox "Data export finished successfully!", vbInformation, "Done"    
End Sub 


Function DataToExcel(strSourceName As String, Optional strWorkbookPath As String, Optional     strTargetSheetName As String)

'Use this function to export a large table/query from your database to a new Excel workbook.
'You can also specify the name of the worksheet target.

'strSourceName is the name of the table/query you want to export to Excel.
'strWorkbookPath is the path of the workbook you want to export the data.
'strTargetSheetName is the desired name of the target sheet.

'By Christos Samaras
'http://www.myengineeringworld.net

Dim rst         As DAO.Recordset
Dim excelApp    As Object
Dim Wbk         As Object
Dim sht         As Object
Dim fldHeadings As DAO.Field

'Set the desired recordset (table/query).
Set rst = CurrentDb.OpenRecordset(strSourceName)

'Create a new Excel instance.
Set excelApp = CreateObject("Excel.Application")

On Error Resume Next

'Try to open the specified workbook. If there is no workbook specified
'(or if it cannot be opened) create a new one and rename the target sheet.
Set Wbk = excelApp.Workbooks.Open(strWorkbookPath)
If Err.Number <> 0 Or Len(strWorkbookPath) = 0 Then
    Set Wbk = excelApp.Workbooks.Add
    Set sht = Wbk.Worksheets("Sheet1")
    If Len(strTargetSheetName) > 0 Then
        sht.Name = Left(strTargetSheetName, 34)
    End If
End If

'If the specified workbook has been opened correctly, then in order to avoid
'problems with other sheets that might contain, a new sheet is added and is
'being renamed according to the strTargetSheetName.
Set sht = Wbk.Worksheets.Add
If Len(strTargetSheetName) > 0 Then
    sht.Name = Left(strTargetSheetName, 34)
End If

On Error GoTo 0

excelApp.Visible = True

On Error GoTo Errorhandler

'Write the headings in the target sheet.
For Each fldHeadings In rst.Fields
    excelApp.ActiveCell = fldHeadings.Name
    excelApp.ActiveCell.Offset(0, 1).Select
Next

'Copy the data in the target sheet.
rst.MoveFirst
sht.Range("A2").CopyFromRecordset rst
sht.Range("1:1").Select

'Format the headings of the target sheet.
excelApp.Selection.Font.Bold = True
With excelApp.Selection
    .HorizontalAlignment = -4108 '= xlCenter in Excel.
    .VerticalAlignment = -4108  '= xlCenter in Excel.
    .WrapText = False
    With .Font
        .Name = "Arial"
        .Size = 11
    End With
End With

'Adjusting the columns width.
excelApp.ActiveSheet.Cells.EntireColumn.AutoFit

'Freeze the first row - headings.
With excelApp.ActiveWindow
    .FreezePanes = False
    .ScrollRow = 1
    .ScrollColumn = 1
End With
sht.Rows("2:2").Select
excelApp.ActiveWindow.FreezePanes = True

'Change the tab color of the target sheet.
With sht
    .Tab.Color = RGB(255, 0, 0)
    .Range("A1").Select
End With

'Close the recordset.
rst.Close
Set rst = Nothing

Exit Function

Errorhandler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
Exit Function

End Function