如何将MS-Acess查询转换为MS-Excel中的工作表
我试图在访问中创build一个VBA脚本，以定期保存一个查询的数据作为一个新的工作表在一个Excel文件。 我已经开始了代码，但坚持如何将查询转换为工作表中的数据。 我确定有一个命令（例如将表格导出为excel文件），但是我一直无法find它。 这是我的代码到目前为止。
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 谢谢，
一个漫长的回答 – 和TransferSpreadsheet可能会为你工作。
我已经写了下面三个过程 – 第一个关系第二个和第三个在一起，第二个创build一个Excel的实例将数据放入，第三个按要求导出查询（或logging集）。
所以首先要把这一切结合起来：
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
接下来，创build一个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
最后，导出查询 – 或logging – 如果需要的话，重命名标题。
'---------------------------------------------------------------------------------- ' 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过程以将不同的工作表和单元格引用传递到主过程时，不要使用单个工作表创build新的工作簿：
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
您正在查找的命令是TransferSpreadsheet。
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "YourQuery", "FilePath.xlsx", True
variables是说你想要一个导出，Excel 2000格式（如果你想要2010，你可以改成acSpreadsheetTypeExcel12），select你的查询，保存的地方，True表示你的导出有字段名。