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

克里斯·谢瓦利埃（Chris Chevalier）

我试图在访问中创建VBA脚本，以定期将查询的数据另存为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

谢谢，

达伦·巴特鲁普·库克（Darren Bartrup-Cook）

答案有点冗长-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

本文收集自互联网，转载请注明来源。

如有侵权，请联系 [email protected] 删除。

编辑于 2021-03-30

我来说两句

0 条评论

登录后参与评论

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

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

UITableView的项目向下滚动后更改颜色，然后快速备份

Linux的官方Adobe Flash存储库是否已过时？

用日期数据透视表和日期顺序查询

应用发明者仅从列表中选择一个随机项一次

Mac OS X更新后的GRUB 2问题

验证REST API参数

Java Eclipse中的错误13，如何解决？

带有错误“ where”条件的查询如何返回结果？

ggplot：对齐多个分面图-所有大小不同的分面

尝试反复更改屏幕上按钮的位置 - kotlin android studio

如何从视图一次更新多行（ASP.NET - Core）

计算数据帧中每行的NA

蓝屏死机没有修复解决方案

在 Python 2.7 中。如何从文件中读取特定文本并分配给变量

离子动态工具栏背景色

VB.net将2条特定行导出到DataGridView

通过 Git 在运行 Jenkins 作业时获取 ClassNotFoundException

在Windows 7中无法删除文件（2）

python中的boto3文件上传

当我尝试下载 StanfordNLP en 模型时，出现错误

Node.js中未捕获的异常错误，发生调用