excel - 如何将 MS-Access 查询转换为 MS-Excel 中的工作表

Question

我正在尝试创建一个 VBA 脚本来 Access 以定期将查询的数据保存为 Excel 文件中的新工作表。我已经启动了代码，但我卡住了如何将查询转换为工作表中的数据。我确定有一个命令可以这样做(例如将表格导出为 excel 文件)，但我一直找不到。到目前为止，这是我的代码。

    Dim xlsApp As Excel.Application
    Dim xlsBook As Excel.Workbook
    Dim xlsSheet As Excel.Worksheet
    Dim SheetName As String
    SheetName = Format(Date, "YYYY MM DD") ' name sheet after date
    Set xlsBook = Workbook.Open("C:\Users\...")
    Set xlsApp = xlsBook.Parent
    Set xlsSheet = xlsBook.sheets(SheetName).Add

谢谢，

Answer 1

有点冗长的答案 - TransferSpreadsheet 可能对你有用。

我在下面编写了三个程序 - 第一个将第二个和第三个连接在一起，第二个创建 Excel 实例以将数据放入其中，第三个根据请求导出查询(或记录集)。

因此，首先将其捆绑在一起的过程:

Public Sub ExportMyQuery()

    Dim oXLApp As Object             'Reference to Excel Application.
    Dim oXLWrkBk As Object           'Reference to workbook.
    Dim oXLWrkSht As Object          'Reference to worksheet.
    Dim colHeadings As Collection

    'Edit - leave these out and it will use the database field names.
    Set colHeadings = New Collection
    colHeadings.Add "MyField1"
    colHeadings.Add "MyField2"
    colHeadings.Add "MyField3"
    colHeadings.Add "MyField4"
    colHeadings.Add "MyField5"
    colHeadings.Add "MyField6"

    Set oXLApp = CreateXL
    Set oXLWrkBk = oXLApp.WorkBooks.Add(-4167) 'xlWBATWorksheet - Workbook with 1 worksheet.
    Set oXLWrkSht = oXLWrkBk.WorkSheets(1)

    'This is the function you're after.  It's not perfect yet (check TO DO comments in the function):
    If QueryExportToXL(oXLWrkSht, "qry_MyQuery", , "Sheet1", oXLWrkSht.cells(2, 1), , colHeadings) = True Then
        MsgBox "Successful"
    Else
        MsgBox "Failed"
    End If

End Sub

接下来，创建一个 Excel 实例(无需先设置对 Excel 的引用):

'----------------------------------------------------------------------------------
' 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. '
            'TO DO: Facility to use an alternative name.                   '
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            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

有点冗长，但您可以重命名标题并导出带有或不带有参数的表或查询，并从特定工作表中的特定单元格开始粘贴结果。

更新:
您可以更改 ExportMyQuery 过程以将不同的工作表和单元格引用传递给主过程，而不是每次都使用单个工作表创建一个新工作簿:

Public Sub ExportMyQuery1()

    Dim oXLApp As Object             'Reference to Excel Application.
    Dim oXLWrkBk As Object           'Reference to workbook.
    Dim oXLWrkSht As Object          'Reference to worksheet.
    Dim colHeadings As Collection

    Set colHeadings = New Collection
    colHeadings.Add "MyField1"
    colHeadings.Add "MyField2"
    colHeadings.Add "MyField3"
    colHeadings.Add "MyField4"
    colHeadings.Add "MyField5"
    colHeadings.Add "MyField6"

    Set oXLApp = CreateXL

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Open an existing workbook and add a sheet at the end. '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set oXLWrkBk = oXLApp.workbooks.Open("C:\Documents and Settings\crladmin.ADMINNOT\Desktop\Book1.xlsx")
    Set oXLWrkSht = oXLWrkBk.worksheets.Add(, oXLWrkBk.worksheets(oXLWrkBk.worksheets.Count))
    Set oXLWrkSht.Name = "A WorkSheet Name"

    If QueryExportToXL(oXLWrkSht, "qry_MyQuery", , oXLWrkSht.Name, oXLWrkSht.Cells(2, 1), , colHeadings) = True Then
        MsgBox "Successful"
    Else
        MsgBox "Failed"
    End If

End Sub

或者:

Public Sub ExportMyQuery2()

    Dim oXLApp As Object             'Reference to Excel Application.
    Dim oXLWrkBk As Object           'Reference to workbook.
    Dim oXLWrkSht As Object          'Reference to worksheet.
    Dim colHeadings As Collection
    Dim x As Long

    Set colHeadings = New Collection
    colHeadings.Add "MyField1"
    colHeadings.Add "MyField2"
    colHeadings.Add "MyField3"
    colHeadings.Add "MyField4"
    colHeadings.Add "MyField5"
    colHeadings.Add "MyField6"

    Set oXLApp = CreateXL

    ''''''''''''''''''''''''''''
    'Open an existing workbook '
    ''''''''''''''''''''''''''''
    Set oXLWrkBk = oXLApp.workbooks.Open("C:\Documents and Settings\crladmin.ADMINNOT\Desktop\Book1.xlsx")

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Create three sheets and export the query results to each sheet. '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    For x = 1 To 3

        Set oXLWrkSht = oXLWrkBk.worksheets.Add(, oXLWrkBk.worksheets(oXLWrkBk.worksheets.Count))
        oXLWrkSht.Name = "A WorkSheet Name" & x

        If QueryExportToXL(oXLWrkSht, "qry_MyQuery", , oXLWrkSht.Name, oXLWrkSht.Cells(2, 1), , colHeadings) = True Then
            MsgBox "Successful"
        Else
            MsgBox "Failed"
        End If

    Next x

End Sub

或者:

Public Sub ExportMyQuery()

    Dim oXLApp As Object             'Reference to Excel Application.
    Dim oXLWrkBk As Object           'Reference to workbook.
    Dim oXLWrkSht As Object          'Reference to worksheet.
    Dim colHeadings As Collection
    Dim x As Long
    Dim lLastRow As Long

    Set colHeadings = New Collection
    colHeadings.Add "MyField1"
    colHeadings.Add "MyField2"
    colHeadings.Add "MyField3"
    colHeadings.Add "MyField4"
    colHeadings.Add "MyField5"
    colHeadings.Add "MyField6"

    Set oXLApp = CreateXL

    ''''''''''''''''''''''''''''
    'Open an existing workbook '
    ''''''''''''''''''''''''''''
    Set oXLWrkBk = oXLApp.workbooks.Open("C:\Documents and Settings\crladmin.ADMINNOT\Desktop\Book1.xlsx")
    Set oXLWrkSht = oXLWrkBk.worksheets.Add(, oXLWrkBk.worksheets(oXLWrkBk.worksheets.Count))
    oXLWrkSht.Name = "A WorkSheet Name"

    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Export the same query to 1 sheet 3 times, appending to the bottom of the data. '
    'NB - I haven't added anything to remove field headings each time.              '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    For x = 1 To 3

        lLastRow = oXLWrkSht.Cells(oXLWrkSht.Rows.Count, "A").End(-4162).Row '-4162 = xlUp

        QueryExportToXL oXLWrkSht, "qry_MyQuery", , oXLWrkSht.Name, oXLWrkSht.Cells(lLastRow + 1, 1), , colHeadings


    Next x

End Sub