Here is an answer I wrote some months ago.
You will need to tweak it a bit to exactly fit your situation.
Your situation needs a different strSQL and a different strFirstCell each
time you do the copy from recordset routine.
'------------------------
'replace the following with your own strings
'strDocPath = "c:\documents and settings\Jeanette\desktop\TemplateB.xls"
'strPath = "c:\documents and settings\Jeanette\desktop\Text.xls"
'strFirstCell = "A5"
'strWsName = "Sheet1"
'strSQL can be a saved query,
'or a saved table,
'or a sql statement
'strSql = "SELECT yadda, yadda " _
' & "FROM yadda " _
' & "WHERE yadda " _
' & "ORDER BY yadda"
'if your template has more than 1 worksheet
'you can choose which worksheet will receive the data
'you can choose which cell to start copying the data to
'------------------------
Public Sub CopyRecordset2XLTemplate()
On Error GoTo SubErr
Dim objXLApp As Object 'Excel.Application
Dim objXLWs As Object 'Excel.Worksheet
Dim strWsName As String 'name of worksheet
Dim strFirstCell As String 'starting point to add the data
Dim rst As DAO.Recordset
Dim strDocPath 'full path and name of template
Dim strPath As String 'full path and name to save file as
Dim strSQL As String 'data to export, table, query or sql statement
Const xlCellTypeLastCell = 11
Const xlContinuous = 1
Const xlAutomatic = -4105
'strDocPath = "c:\documents and settings\Jeanette\desktop\TemplateB.xls"
'strPath = "c:\documents and settings\Jeanette\desktop\Text.xls"
'strFirstCell = "A5"
'strWsName = "Sheet1"
'strSQL = "QueryName"
strDocPath = "c:\documents and
settings\jc.ECJ-02.000\desktop\MyPersonxpt.xls"
strPath = "c:\documents and
settings\jc.ECJ-02.000\desktop\MyNewPersonxpt.xls"
strWsName = "S1"
'name of the recordset to copy
strSQL = "qryNewStatusExport"
strFirstCell = "A4"
'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)
'Open a recordset on the table with query and worksheet names
Set rst = CurrentDb.OpenRecordset(strSQL)
If rst.EOF Then
'handle error here
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
strFirstCell
objXLWs.Range(strFirstCell).CopyFromRecordset rst
' Select the main worksheet
objXLApp.Worksheets(strWsName).Activate
' Activate the selected worksheet
Set objXLWs = objXLApp.ActiveWorkbook.Worksheets(strWsName)
'format cells
With objXLWs.Cells
.Range(.Cells(1, 1), .Cells(1, _
1).SpecialCells(xlCellTypeLastCell)).Borders.LineStyle = _
xlContinuous
.Range(.Cells(1, 1), .Cells(1, _
1).SpecialCells(xlCellTypeLastCell)).Borders.ColorIndex = _
xlAutomatic
.Font.Size = 9
.Font.Name = "Arial Narrow"
.WrapText = True
End With
End If
'**error handling, in the Sub exit - make sure you set the object
'references to nothing as shown below.
SubExit:
' Save the workbook
objXLApp.ActiveWorkbook.Save
Set objXLWs = Nothing
Set objXLApp = Nothing
' Destroy the recordset and database objects
rst.Close
If Not rst Is Nothing Then
Set rst = Nothing
End If
Exit Sub
SubErr:
MsgBox Err.Description & " " & Err.Number
Resume SubExit
End Sub
'-------------------------------
Jeanette Cunningham -- Melbourne Victoria Australia
