使用 Access VBA 将数据从 Access 导入 Excel

Question

我想向您寻求有关 Access VBA 代码的帮助，该代码会将 1 个指定查询表中的所有数据从 Access 数据库（当前打开的数据库）导入 MS Excel（文件，可以选择由用户）。

我目前正在使用这段代码，但我收到错误消息：

“运行时错误'-2147023170 (800706be)':

自动化错误远程过程调用失败。”

有人知道如何修复连接吗？

Option Explicit
Option Compare Database

    Public Sub CopyRstToExcel_test()
    'On Error GoTo CopyRstToExcel_Err

        Dim sPath As String
        Dim fd As FileDialog
        Dim oExcel As Object
        Dim oExcelWrkBk As Object
        Dim oExcelWrSht As Object

        Dim dbs 'Added
        Dim qdfName As String
        Dim fRecords As Boolean

        Dim rst As dao.Recordset

        Dim iCols As Integer

        '-------------------------------------------------------------------------------------------------------------------------------------------------------------------
        ' Select the file and identify the path leading to the file
        '-------------------------------------------------------------------------------------------------------------------------------------------------------------------

        'Define database you want to work with
        Set dbs = CurrentDb

        'Select the Excel file you want to work with
        Set fd = Application.FileDialog(msoFileDialogFilePicker)

        'Define the path
        If fd.Show = -1 Then
            sPath = fd.SelectedItems(1)
        End If

        MsgBox sPath

        '-------------------------------------------------------------------------------------------------------------------------------------------------------------------
        ' Defining names of variables
        '-------------------------------------------------------------------------------------------------------------------------------------------------------------------

        'Defining variables (queries/tables)
        qdfName = "Query_1"

        '------------------------------------------------------------------------------------------------
        'Copying the data from Access into the new Excel
        '------------------------------------------------------------------------------------------------

        Set rst = CurrentDb.OpenRecordset(qdfName, dbOpenSnapshot)

        fRecords = False
        If rst.EOF = False Then
            fRecords = True

            Set oExcel = CreateObject("Excel.Application")
            Set oExcelWrkBk = GetObject(sPath)

            oExcel.Visible = True
            oExcel.ScreenUpdating = False

            Set oExcelWrSht = oExcelWrkBk.Sheets(1)

            For iCols = 0 To rst.Fields.Count - 1
                oExcelWrSht.Cells(9, iCols + 2).Value = rst.Fields(iCols).Name
            Next

            oExcelWrSht.Range(oExcelWrSht.Cells(9, 2), _
                oExcelWrSht.Cells(9, rst.Fields.Count)).Font.Bold = True

            oExcelWrSht.Range("B10").CopyFromRecordset rst

            oExcelWrSht.Range(oExcelWrSht.Cells(9, 2), _
                oExcelWrSht.Cells(rst.RecordCount + 9, rst.Fields.Count)).Columns.AutoFit

            oExcelWrSht.Range("A1").Select

        End If


    '------------------------------------------------------------------------------------------------
    CopyRstToExcel_Done:
        On Error Resume Next
        If fRecords = True Then
            oExcel.Visible = True
            oExcel.ScreenUpdating = True
        End If
        Set oExcelWrSht = Nothing
        Set oExcelWrkBk = Nothing
        Set oExcel = Nothing
        Set rst = Nothing

    ''Error message:
    'CopyRstToExcel_Err:
    '    MsgBox Err & ": " & Error, vbExclamation
    '    Resume CopyRstToExcel_Done
    '    Resume
    '------------------------------------------------------------------------------------------------

    End Sub

在这一步中，我只想复制第一张表格中的数据，但稍后我还想指定表格的名称，并且我已经准备好要复制数据的模板。

感谢您的帮助！

Answer 1

尝试替换

Set oExcelWrkBk = GetObject(sPath)

通过

Set oExcelWrkBk = oExcel.Workbooks.Open(sPath)

我也建议更换

Set rst = CurrentDb.OpenRecordset(qdfName, dbOpenSnapshot)

通过

Set rst = dbs.OpenRecordset(qdfName, dbOpenSnapshot)

打开指定的工作表：

Set oExcelWrSht = oExcelWrkBk.Sheets("MyWorksheetName")