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

Question

I'm trying to create a VBA script in access to periodically save a query's data as a new sheet in a excel file. I've started the code but am stuck how to convert a query to data in the sheet. I'm sure there is a command to do so (such as exporting a table as a excel file) but I haven't been able to find one. Here is my code so far.

    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

Thanks,

Answer 1

A bit of a long winded answer - and TransferSpreadsheet will probably work for you.

I've written three procedures below - the first ties the second and third together, the second creates an instance of Excel to put the data into, the third exports the query (or recordset) as requested.

So first the procedure to tie it all together:

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

Next, create an instance of Excel (no need to set references to Excel first):

'----------------------------------------------------------------------------------
' 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

Finally, export the query - or recordset - and rename the headings if you want.

'----------------------------------------------------------------------------------
' 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

A bit long winded, but you can rename headings and export tables or queries with or without parameters and paste the result starting at a specific cell within a specific worksheet.

---

Update: Rather than create a new workbook with a single worksheet each time you can change the ExportMyQuery procedure to pass different worksheets and cell references to the main procedures:

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

or:

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

or:

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

Answer 2

The command you're looking for is TransferSpreadsheet.

    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "YourQuery", "FilePath.xlsx", True

The variables are saying that you want an export, Excel 2000 format (you can change to acSpreadsheetTypeExcel12 if you want 2010 instead), choosing your query, where to save, and the True indicates that your export has field names.