Try this
Make a table (tblExport) to store the names of the queries to export with
the worksheet names
Create a table with 2 fields
field 1 -- QueryN -- text 'for name of each query to export
field 2 -- WorksheetN -- text 'for the corresponding worksheet name
save the table as tblExport
Add your query names and worksheet names to tblExport
I haven't tested this code extensively, but it worked for me.
-----------------------------------
Private Function MyExportMulti()
On Error GoTo FunctionErr
Dim objXLApp As Object
Dim objXLws As Object
Dim db As DAO.Database
Dim rstCopy As DAO.Recordset
Dim rstMain As DAO.Recordset
Dim strDocPath 'full path and name of template
Dim strSavePath As String 'full path and name to save file as
Dim strWsName As String 'name of worksheet
Dim strQueryName As String
strDocPath = "your template file name and path here"
strPath = "your save file name and path here"
'replace with names and cell references that suit your setup
'Populate the excel object
Set objXLApp = CreateObject("Excel.Application")
'Open the template workbook
objXLApp.Workbooks.Open (strDocPath)
'Save the template as the file specified by the user
objXLApp.activeworkbook.SaveAs (strSavePath)
Set db = DBEngine(0)(0)
'Open a recordset on the table with query and worksheet names
Set rstMain = db.OpenRecordset("tblExport")
'make sure at start of table
rstMain.MoveFirst
'Use the recordset as a base
With rstMain
' Process until end of file
Do While Not .EOF
'get the name of the query
strQueryName = rstMain("QueryN")
'get the name of the worksheet
strWsName = rstMain("WorksheetN")
' Open a recordset on the query for the data to export
Set rstCopy = db.OpenRecordset(strQueryName)
' If there are no records, return an error
If rstCopy.EOF Then
MsgBox "error, no data"
Else
' Select the appropriate worksheet
Set objXLws = objXLApp.activeworkbook.Worksheets(strWsName)
' Activate the selected worksheet
objXLws.Activate
' Ask Excel to copy the data from the recordset starting
with cell A5
objXLws.Range("A5").CopyFromRecordset rstCopy
' Select the main worksheet
objXLApp.Worksheets(strWsName).Activate
' Activate the selected worksheet
Set objXLws = objXLApp.activeworkbook.Worksheets(strWsName)
'close the 1st recordset
rstCopy.Close
Set rstCopy = Nothing
End If
rstMain.MoveNext
Loop
End With
'**error handling, in the function exit - make sure you set the object
'references to nothing as shown below.
FunctionExit:
'Hide warnings on the spreadsheet
objXLApp.DisplayAlerts = False
'Save the workbook
objXLApp.activeworkbook.Save
'Turn spreadsheet warnings back on
objXLApp.DisplayAlerts = True
'Make it visible
objXLApp.Visible = True
Set objXLws = Nothing
Set objXLApp = Nothing
'Destroy the recordset and database objects
rstMain.Close
If Not rstCopy Is Nothing Then
Set rstCopy = Nothing
End If
If Not rstMain Is Nothing Then
Set rstMain = Nothing
End If
If Not db Is Nothing Then
Set db = Nothing
End If
Exit Function
FunctionErr:
MsgBox Err.Description & " " & Err.Number
Resume FunctionExit
End Function
---------------------------
Jeanette Cunningham
Sorry, clicked send accidentally before I had finished the previous post.
Here is an example using excel's copy from recordset method.
This is an example for one worksheet.
When I get time I will have a look at extending the code to multiple
spreadsheets in the same workbook.
Dim objXLApp As Object
Dim objXLws As Object
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim strDocPath 'full path and name of template
Dim strPath As String
Set db = DBEngine(0)(0)
' Open a recordset on the query for the data to export
Set rst = db.OpenRecordset("your query")
' If there are no records, return an error and exit function
If rst.EOF Then
msgbox "error, no data"
Exit Function
End If
'replace with names and cell references that suit your template
' Populate the excel object
Set objXLApp = CreateObject("Excel.Application")
' Open the template workbook
objXLApp.Workbooks.Open (strDocPath)
' Save the template as the file specified by the user
objXLApp.ActiveWorkbook.SaveAs (strPath)
' Select the appropriate worksheet
Set objXLws = objXLApp.ActiveWorkbook.Worksheets("TheWsName")
' Activate the selected worksheet
objXLws.Activate
' Ask Excel to copy the data from the recordset starting with cell A5
objXLws.Range("A5").CopyFromRecordset rst
' Select the main worksheet
objXLApp.Worksheets("TheWsName").Activate
' Activate the selected worksheet
Set objXLws = objXLApp.ActiveWorkbook.Worksheets("TheWsName")
' Hide warnings on the spreadsheet
objXLApp.DisplayAlerts = False
' Save the workbook
objXLApp.ActiveWorkbook.Save
' Turn spreadsheet warnings back on
objXLApp.DisplayAlerts = True
' Make it visible
objXLApp.Visible = True
'**error handling, in the function exit - make sure you set the object
'references to nothing as shown below.
FunctionExit:
Set objXLws = Nothing
Set objXLApp = Nothing
' Destroy the recordset and database objects
rst.Close
Set rst = Nothing
Set db = Nothing
Exit Function
Jeanette Cunningham
Hi Jeanette,
Thank you in million times. It works as beautiful.
I try to learn how to add 2nd worksheet related "My Query #2" but I
couldn't. Your help would be much appreciated if you provide extra
sample of code to add 2nd worksheet related "My Query #2"
