Question

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

我试图将此输出分解为多个文件。

我仍然是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

但是，我得到了：

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

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

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

感谢您的帮助！

Answer 1

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

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

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

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

1 个答案: