我试图在访问中创建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
谢谢,
答案有点冗长-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] 删除。
我来说两句