[AccessD] Exporting From Access to Excel

Thank you

-----Original Message-----
From: A.D.TEJPAL [mailto:adtp at hotmail.com] 
Sent: Friday, May 18, 2007 12:27 AM
To: Access Developers discussion and problem solving
Subject: Re: [AccessD] Exporting From Access to Excel

Debbie,

    Two of my sample db's mentioned below, might be of interest to you:

    (a) ExportAccessToExcelMultiSheets
    (b) ExportAccessToExcelAsPivotTable

    Both samples (in Access 2000 file format) are available at Rogers Access
Library (other developers library). Link -
http://www.rogersaccesslibrary.com/OtherLibraries.asp#Tejpal,A.D.


    Sample (b), is not restricted to pivot tables alone and might be found
more convenient if you do not wish to install & register a browser control.

    You could adapt the underlying approach suitably, for your specific
needs.
 
Best wishes,
A.D.Tejpal
---------------

  ----- Original Message ----- 
  From: Elam, Debbie 
  To: 'Access Developers discussion and problem solving' 
  Sent: Thursday, May 17, 2007 20:30
  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