[AccessD] Report to Excel_

Mark,

I've been kind-of following this thread and thought I'd share my code with
you.
It may not help you with what you're doing, but it's a slightly different
approach.
I use an Excel sheet as a template to do some of my formatting. I open it,
use the CopyFromRecordset function to paste the data into Excel, then do a
"Save AS". The nice thing about the template is you can make a formatting
change to it instead of having to do it in the code. There will probably be
some need to still do some vba-code formatting of the spreadsheet, but this
can cut down on some of the coding. 

Note: You can't paste the code below and run it because I cut it up a little
to make it more succinct, but it may give you some other ideas. I also have
some error trapping codes at the end that may help.

John
----


Private Sub btnExportToExcelX()

On Error GoTo Err_btnExportToExcel

Dim objXLBook As Excel.Workbook
Dim rsFinalBidQuery As dao.Recordset, varResults As Variant
Dim objXLRange As Excel.Range, objXLApp As Excel.Application
Dim objResultsSheet As Excel.Worksheet
Dim intMaxCol As Integer
Dim intMaxRow As Integer
Dim strExportFilename As String, strFullXLTemplateFilename As String
    
strExportFilename =TestWorkbook.xls"
strFullXLTemplateFilename = "c:\ExcelTemplateFile.xls"

Set objXLBook = GetObject(strFullXLTemplateFilename)
Set objXLApp = objXLBook.Parent
Set objResultsSheet = objXLBook.Worksheets(1)
  
Set rsFinalBidQuery = CurrentDb().OpenRecordset("qryToExport")
    rsFinalBidQuery.MoveLast
   rsFinalBidQuery.MoveFirst
    
   '*Store the data in the worksheet
   intMaxCol = rsFinalBidQuery.Fields.Count
      If rsFinalBidQuery.RecordCount > 0 Then
        intMaxRow = rsFinalBidQuery.RecordCount
        With objXLApp
          With objResultsSheet
            .Range(.Cells(11, 2), .Cells(11 + intMaxRow, 2 +
intMaxCol)).CopyFromRecordset rsFinalBidQuery
          End With
        End With
      End If
    
rsFinalBidQuery.Close
    
'Add some values to specific defined cells
objResultsSheet.Range("PartNum").Value = "PN# 1234"
objResultsSheet.Range("PartDesc").Value = "Description"
    
objXLBook.Parent.Windows(objXLBook.Name).Visible = True

'Save it as a new name
objXLBook.SaveAs strExportFilename
objXLApp.Visible = True

' Release the object variable
Set objXLBook = Nothing
 
BuildXLBidReport_EXIT:
Set rsFinalBidQuery = Nothing

DoCmd.Hourglass False
DoCmd.Echo True

Exit Sub

BuildXLBidReport_ERR:

'If user picks to cancel the opening of the worksheet because of the excel
macro message this error occurs
If Err = 287 Then Resume BuildXLBidReport_EXIT

If Err = 70 Then
    MsgBox " Make sure this worksheet **" & strExportFilename & "** isn't
alreday open.", 64, "Excel Sheet Open"
    Resume BuildXLBidReport_EXIT
End If
If Err = 1004 Then
    MsgBox " Make sure this worksheet **" & strExportFilename & "** isn't
alreday open.", 64, "Excel Sheet Open"
    objXLBook.Application.Quit
    ' Release the object variable
    Set objXLBook = Nothing
    Resume BuildXLBidReport_EXIT
End If
    
'Display the error

      Dim strCallingObject As String
      strCallingObject = "BuildXLBidReport" & "  " &
Application.CurrentObjectName & " Line: " & Erl
      lg_VarTemp = lbf_ErrorMessage(Err, Error, strCallingObject)
      Resume BuildXLBidReport_EXIT

    Dim oApp As Object

    Set oApp = CreateObject("Excel.Application")
    oApp.Visible = True
    'Only XL 97 supports UserControl Property
    On Error Resume Next
    oApp.UserControl = True

Exit_btnExportToExcel:
    Exit Sub

Err_btnExportToExcel:
    MsgBox Err.Description
    Resume Exit_btnExportToExcel
    
End Sub