[AccessD] Exporting From Access to Excel

If you are opening an Excel .xlt template file you do not need to do a
file copy. The template will open as "yourfilename1.xls".You only need
to save it:

appExcel.ActiveWorkbook.SaveAs FileName:=strFileSave
appExcel.ActiveWorkbook.Close SaveChanges:=True
Where strFilesave is the name you wish to save it under.

Are you sure yout template has 3 worksheets? I suspect worksheet(3)
doesn't exist in the workbook so you are erroring out. Also, you may
still have excel orphan instances from previous runs (check task master)
since I don't see

 appexcel.Quit
 Set appexcel = Nothing

Also, you might try 
appExcel.Range("C4").CopyFromRecordset rst 
To do your copying rather than going row by row.

HTH
Jim Hale

-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Elam, Debbie
Sent: Thursday, May 17, 2007 10:00 AM
To: 'Access Developers discussion and problem solving'
Subject: [AccessD] Exporting From Access to Excel


I found a bit of code that allows me to export to specific worksheets in
Excel.  The intent being that I would have a 3 worksheet export of a
report. The code works very well except for one little snag at the end.
I get a runtime error 7952, you made an illegal function call, and the
resulting spreadsheet is the same size as the template.  When I open the
worksheet, it actually opens 2 of them, one that has only the template
info in it that has the file name I designated, and a second underneath
that is correct and apparently not saved?  I can save this but it
generally will not save under the filename I designated.  I tried adding
a save command to the end of the code, but it simply says I already have
a file with that name do I want to replace.  Clicking yes is ignored and
it brings up a dialog to save it as [filename]1.xls.  Once again
[filename].xls is blank except for template included items and the
[filename]1.xls comes out like I planned.  This one does not seem to
have the full file hiding in it either.  This is a lot better than
having the "good" file hide inside the blank one, but still not really
where I would like it to be for less tech savvy users. 

Here is the code:


Public Function ExportRequestHardCode(strTemplate As String,
strOutputFile As String) As String
   On Error GoTo err_Handler
   
   ' Excel object variables
   Dim appExcel As Excel.Application
   Dim wbk As Excel.Workbook
   Dim wks As Excel.Worksheet
   Dim sTemplate As String
   Dim sTempFile As String
   Dim sOutput As String
   
   Dim dbs As DAO.Database
   Dim rst As DAO.Recordset
   Dim sSQL As String
   Dim lRecords As Long
   Dim iRow As Integer
   Dim iCol As Integer
   Dim iFld As Integer
   
   Const cTabTwo As Byte = 2
   Const cStartRow As Byte = 2
   Const cStartColumn As Byte = 1
   
   DoCmd.Hourglass True
   
   ' set to break on all errors
   Application.SetOption "Error Trapping", 0
   
   ' start with a clean file built from the template file
   sTemplate = CurrentProject.Path & strTemplate
   sOutput = strOutputFile
   'If Dir(sOutput) <> "" Then Kill sOutput
   FileCopy strTemplate, sOutput
   
   ' Create the Excel Applicaiton, Workbook and Worksheet and Database
object
   Set appExcel = Excel.Application
   Set wbk = appExcel.Workbooks.Open(sOutput)

StartofTab1:
   Set wks = appExcel.Worksheets(1)
   sSQL = "AAAllConsolidatedUnionOlderThan2K"
   Set dbs = currentdb
   Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
   
   ' For this template, the data must be placed on the 4th row, third
column.
   ' (these values are set to constants for easy future modifications)
   iCol = 1
   iRow = 2
   If Not rst.BOF Then rst.MoveFirst
   Do Until rst.EOF
      iFld = 0
      lRecords = lRecords + 1
      'Me.lblMsg.Caption = "Exporting record #" & lRecords & " to " &
strTemplate
      'Me.Repaint
      
      For iCol = 1 To 1 + (rst.Fields.Count - 1)
         wks.Cells(iRow, iCol) = rst.Fields(iFld)
         
         If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
            wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
         End If
         
         wks.Cells(iRow, iCol).WrapText = True
         iFld = iFld + 1
      Next
      
      wks.Rows(iRow).EntireRow.AutoFit
      iRow = iRow + 1
      rst.MoveNext
   Loop
   
   'ExportRequest = "Total of " & lRecords & " rows processed."
   'Me.lblMsg.Caption = "Total of " & lRecords & " rows processed."
   Set rst = Nothing
   Set dbs = Nothing
   
StartofTab2:
   Set wks = appExcel.Worksheets(2)
   sSQL = "AAAllConsolidatedUnionBetween2Kand06"
   Set dbs = currentdb
   Set rst = dbs.OpenRecordset(sSQL, dbOpenDynaset, dbReadOnly)
   
   ' For this template, the data must be placed on the 4th row, third
column.
   ' (these values are set to constants for easy future modifications)
   iCol = 1
   iRow = 2
   If Not rst.BOF Then rst.MoveFirst
   Do Until rst.EOF
      iFld = 0
      lRecords = lRecords + 1
      'Me.lblMsg.Caption = "Exporting record #" & lRecords & " to " &
strTemplate
      'Me.Repaint
      
      For iCol = 1 To 1 + (rst.Fields.Count - 1)
         wks.Cells(iRow, iCol) = rst.Fields(iFld)
         
         If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
            wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
         End If
         
         wks.Cells(iRow, iCol).WrapText = True
         iFld = iFld + 1
      Next
      
      wks.Rows(iRow).EntireRow.AutoFit
      iRow = iRow + 1
      rst.MoveNext
   Loop
   
   'ExportRequest = "Total of " & lRecords & " rows processed."
   'Me.lblMsg.Caption = "Total of " & lRecords & " rows processed."
   Set rst = Nothing
   Set dbs = Nothing
   
StartofTab3:
   Set wks = appExcel.Worksheets(3)
   sSQL = "AAAllConsolidatedUnionAfter06"
   Set dbs = currentdb
   Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
   
   ' For this template, the data must be placed on the 4th row, third
column.
   ' (these values are set to constants for easy future modifications)
   iCol = 1
   iRow = 2
   If Not rst.BOF Then rst.MoveFirst
   Do Until rst.EOF
      iFld = 0
      lRecords = lRecords + 1
      'Me.lblMsg.Caption = "Exporting record #" & lRecords & " to " &
strTemplate
      'Me.Repaint
      
      For iCol = 1 To 1 + (rst.Fields.Count - 1)
         wks.Cells(iRow, iCol) = rst.Fields(iFld)
         
         If InStr(1, rst.Fields(iFld).Name, "Date") > 0 Then
            wks.Cells(iRow, iCol).NumberFormat = "mm/dd/yyyy"
         End If
         
         wks.Cells(iRow, iCol).WrapText = True
         iFld = iFld + 1
      Next
      
      wks.Rows(iRow).EntireRow.AutoFit
      iRow = iRow + 1
      rst.MoveNext
   Loop
   
   'ExportRequest = "Total of " & lRecords & " rows processed."
   'Me.lblMsg.Caption = "Total of " & lRecords & " rows processed."
   


exit_Here:
   ' Cleanup all objects  (resume next on errors)
   On Error Resume Next
   appExcel.SaveWorkspace (sOutput)
   Set wks = Nothing
   Set wbk = Nothing
   Set appExcel = Nothing
   Set rst = Nothing
   Set dbs = Nothing
   DoCmd.Hourglass False
   Exit Function
   
err_Handler:
   'ExportRequest = Err.Description
   'Me.lblMsg.Caption = Err.Description
   MsgBox Err.Description, vbOKOnly
   Resume exit_Here
   
End Function
-- 
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com

***********************************************************************
The information transmitted is intended solely for the individual or
entity to which it is addressed and may contain confidential and/or
privileged material. Any review, retransmission, dissemination or
other use of or taking action in reliance upon this information by
persons or entities other than the intended recipient is prohibited.
If you have received this email in error please contact the sender and
delete the material from any computer. As a recipient of this email,
you are responsible for screening its contents and the contents of any
attachments for the presence of viruses. No liability is accepted for
any damages caused by any virus transmitted by this email.