[AccessD] Access To Excel via a CSV File

Hi Max,

I do a lot of Access to Excel.  The only reason I would go to a CSV file
first is because there is a limit to the number of rows that you can send to
Excel - it is somewhere around 4,000.  If I know I am going to hit that
limit I go to CSV first, then open it in Excel and do the totals,
formatting, etc.  I leave Excel open and it is left to the user to do the
saving as xls.  I always keep Excel hidden until I am done so that users
don't start clicking away as data is transferring.

Also, I never use transferspreadsheet.  I always step through a recordset
and transfer data row by row.  It is quick and gives me much more control.
For instance, date values have to be sent to Excel already formatted.  If
you don't format them first they will send as integer and it seems that no
amount of formatting in Excel will bring them back around to dates.

Here is some sample code, watch the word wrap.  The routines for getting
Excel open comes from Dev Ashish's site:

Public Sub ToExcel()
On Error GoTo ErrorHandler
    
    Dim strErrMsg As String  'for Error Handling
    Dim X As Integer
    Dim objXL As Excel.Application
    Dim objWkb As Excel.Workbook
    Dim objSht As Excel.Worksheet
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim prm As DAO.Parameter
    Dim rsACData As DAO.Recordset

    Set db = CurrentDb
    Set qdf = db.QueryDefs("somequery")
    For Each prm In qdf.Parameters
        prm.Value = Eval(prm.Name)
    Next prm
    Set rsACData = qdf.OpenRecordset(dbOpenDynaset)
    
    'export data to Excel
    If (Not rsACData.EOF) And (Not rsACData.BOF) Then
        If fIsAppRunning("Excel") Then
            Set objXL = GetObject(, "Excel.Application")
        Else
            Set objXL = CreateObject("Excel.Application")
        End If
        With objXL
            .Visible = False
            Set objWkb = .Workbooks.Add
            Set objSht = objWkb.Worksheets(1)
            With objSht
                .Cells(1, 1) = "Title"
                .Cells(2, 1) = "Another Title"
                .Cells(1, 1).Font.Bold = True
                .Cells(2, 1).Font.Bold = True
                
                .Cells(3, 1) = "Column Heading"
                .Cells(3, 2) = "Column Heading"
                .Cells(3, 3) = "Column Heading"
                .Cells(3, 4) = "Column Heading"
                .Cells(3, 5) = "Column Heading"
                .Cells(3, 6) = "Column Heading"
                .Cells(3, 7) = "Column Heading"
                
                .Rows(3).Font.Bold = True
                .Rows(3).WrapText = True
                
                .Columns(1).ColumnWidth = 10
                .Columns(2).ColumnWidth = 15
                .Columns(3).ColumnWidth = 10
                .Columns(4).ColumnWidth = 30
                .Columns(5).ColumnWidth = 10
                .Columns(6).ColumnWidth = 10
                .Columns(7).ColumnWidth = 10
                                
                X = 4
                rsACData.MoveFirst
                Do Until rsACData.EOF
                    .Cells(X, 1) = rsACData!SomeField
                    .Cells(X, 2) = rsACData! SomeField
                    .Cells(X, 3) = rsACData! SomeField
                    .Cells(X, 4) = Format(rsACData! SomeDateField, "Short
Date")
                    .Cells(X, 5) = rsACData! SomeField
                    .Cells(X, 6) = rsACData! SomeField
                    .Cells(X, 7) = rsACData! "=B" & X & "+C" & X & "+E" & X
& "+F" & X
                    X = X + 1
                    rsACData.MoveNext
                Loop

	      'totals
                    .Cells(X, 1) = "Totals"
                    .Cells(X, 2) = "=Sum(B4:B" & X - 1 & ")"
                    .Cells(X, 3) = "=Sum(C4:C" & X - 1 & ")"
                    .Cells(X, 5) = "=Sum(E4:E" & X - 1 & ")"
                    .Cells(X, 6) = "=Sum(F4:F" & X - 1 & ")"
                
                .Columns(5).NumberFormat = "#,##0.0_)"
	    .Columns(6).NumberFormat = "$#,##0.00_);[Red] ($#,##0.00)"
                
                .PageSetup.PrintGridlines = True
                .PageSetup.Orientation = xlPortrait
                .PageSetup.PrintTitleRows = .Rows(2).Address
                objXL.Visible = True
                objXL.Cells(4, 1).Select
                objXL.ActiveWindow.FreezePanes = True
                            
            End With
        End With
    Else
        MsgBox "No data", vbOKOnly + vbExclamation, "No data"
    End If
    

ExitHere:
    qdf.Close
    rsACData.Close
    Set db = Nothing
    Set objSht = Nothing
    Set objWkb = Nothing
    Set objXL = Nothing
    DoCmd.Hourglass False
    DoCmd.SetWarnings True
    Exit Sub
    
ErrorHandler:
    Select Case Err
        Case 91
            'do nothing - object never opened
            Err.Clear
            Resume Next
        Case 2501
            'no data in report - do nothing
            Err.Clear
            Resume Next
        Case Else
            strErrMsg = "An error occurred in " & "ToExcel" & vbCrLf &
vbCrLf & vbCrLf
            strErrMsg = strErrMsg & "Error #: " & Format$(Err.Number) &
vbCrLf & vbCrLf
            strErrMsg = strErrMsg & "Error Description: " & Err.Description
            MsgBox strErrMsg, vbInformation, "ToExcel"
            Resume ExitHere
    End Select
End Sub

I hope this helps,

Jennifer

-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Max Wanadoo
Sent: Thursday, June 05, 2008 6:34 AM
To: 'Access Developers discussion and problem solving'
Subject: [AccessD] Access To Excel via a CSV File


Can any of you Access/Excel gurus help here please.
I need to create a csv spreadsheet by code.  When it is complete, I need to
put formatting on it. Ie,make columns into Currency Types. Bold some Rows,
set some bacground colours, etc.
I have got as far as creating the CSV ok but then I am stumped.
Any advice most welcome.
Ta
Max

--
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com