Quote:
|
quote:Each query contains its own information so they cant be combined into one
|
Does that mean each result set has a different schema (different column names)? If so, not sure I'd want to touch that one (yikes!), but if you are working with queries with similar but different schema, you might try something like the following:
The Sub below adds two result sets to a single Excel spreadsheet. The first result set lists all of your customers in a given city, and the second result set lists all of your service reps in that city. The two result sets are separated by a blank line on the spread sheet. The results look like:
ID Name City
BOLID Bólido Comidas preparadas Madrid
FISSA FISSA Fabrica Inter. Salchichas S.A. Madrid
ROMEY Romero y tomillo Madrid
5 "Buchanan, Steven" Madrid
1 "Davolio, Nancy" Madrid
2 "Fuller, Andrew" Madrid
3 "Leverling, Janet" Madrid
4 "Peacock, Margaret" Madrid
Notice that the results sets share a similar schema. If your schema are really different, you might be able to get this to fly using some pretty generic column headers.
The three columns in the template file are: ID, Name, City
The module copies the template file to an output directory before filling it using a FileSystem object, so you’ll need to reference the Microsoft Scripting Runtime library. The code opens an Excel database connection using the Jet driver, then opens two recordset objects which are used to populate the spreadsheet.
The module is called with something like:
ExportToExcel "C:\Output\CompaniesEmployeesList.xls"
~~~~~Code~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub ExportToExcel(strOutputFile As String, Optional boolSuppressMessages As Boolean = False)
Dim strTemplateFile As String
Dim fso As Scripting.FileSystemObject
Dim cnn As ADODB.Connection
Dim rstTarget As ADODB.Recordset
Dim rstCustomers As ADODB.Recordset
Dim rstServiceReps As ADODB.Recordset
On Error GoTo ErrorHandler: On Error GoTo 0
Set fso = New Scripting.FileSystemObject
' Get template file path
strTemplateFile = CurrentProject.path & "\CompaniesEmployeesList.xlt"
' Copy template to the target
fso.CopyFile strTemplateFile, strOutputFile, False
' Open a connection to the workbook
Set cnn = New ADODB.Connection
cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
cnn.ConnectionString = "Data Source=" & strOutputFile & ";" & _
"Extended Properties=""Excel 8.0"""
cnn.Mode = adModeReadWrite
cnn.Open
' Open the target recordset (the Excel sheet)
Set rstTarget = New ADODB.Recordset
rstTarget.Open "SELECT [ID], [Name], [City] " & _
"FROM [Sheet1$]", cnn, adOpenDynamic, adLockOptimistic
' Open Customer data recodset
Set rstCustomers = New ADODB.Recordset
rstCustomers.Open "SELECT CompanyID, CompanyName, City " & _
"FROM Customers " & _
"WHERE City = 'Madrid' " & _
"ORDER BY CompanyName", CurrentProject.Connection
' Open Service Rep data recodset
Set rstServiceReps = New ADODB.Recordset
rstServiceReps.Open "SELECT EmployeeID, [LastName] & "", "" & [FirstName] AS Name, City " & _
"FROM Employees " & _
"WHERE City = 'Madrid' " & _
"ORDER BY [LastName]", CurrentProject.Connection
' Loop through Customers result set and copy to target
Do While Not rstCustomers.EOF
rstTarget.AddNew
rstTarget![ID] = rstCustomers!CompanyID
rstTarget![Name] = rstCustomers!CompanyName
rstTarget![City] = rstCustomers!City
rstCustomers.MoveNext
Loop
' Insert blank line between result sets.
rstTarget.AddNew
rstTarget![ID] = ""
rstTarget![Name] = ""
rstTarget![City] = ""
rstTarget.Update
' Loop through Service Reps result set and copy to target
Do While Not rstServiceReps.EOF
rstTarget.AddNew
rstTarget![ID] = rstServiceReps!EmployeeID
rstTarget![Name] = rstServiceReps!Name
rstTarget![City] = rstServiceReps!City
rstTarget.Update
rstServiceReps.MoveNext
Loop
rstTarget.Close
rstCustomers.Close
rstServiceReps.Close
cnn.Close
If Not boolSuppressMessages Then
MsgBox "Workbook Created", vbInformation + vbOKOnly, "ExcelExport"
End If
ExitHere:
On Error Resume Next
Set rstTarget = Nothing
Set cnn = Nothing
Set rstCustomers = Nothing
Set rstServiceReps = Nothing
Exit Sub
ErrorHandler:
Eval "MsgBox(""Error " & Err.Number & "@" & Err.Description & "@"")"
On Error Resume Next
If Not cnn Is Nothing Then
cnn.Close
End If
Resume ExitHere
End Sub
HTH,
Bob
Exporting From Access To Excel
Linear Mode
