Access report in Excel Output

I use VBA to generate output files in Excel from Access reports.  It works just fine except the format of the Excel output file.  Below script as part of the total code block is running okay to generate Excel output files and place them in a desired location.  Code looks into the file and picks up the customer name and number then cerates a string with the xls extension and puts it in the desired location which is selected by the user via the browse button.

DoCmd.OutputTo acOutputReport, "Excel Cust Price List NEWDESC1", acFormatXLS, sFile, False

The issue is that after the file is generated and placed in the right place when it is opened there is a blank row after the title row and data is grouped.  I just can't get the output file to be displayed without the blank row and grouping and can't figure out why it shows that way.

Below is the complete code that runs the above described process.

Public Sub Make_Excel_Files1(Optional ByVal sOutputPathNEWDESC As String = vbNullString)
    Dim db As DAO.Database

    Dim rsCustomers As DAO.Recordset

    Dim qdfReportData As DAO.QueryDef
    Dim rsReportData As DAO.Recordset

    Dim sOldSQL As String 'variable to hold original sql statement
    Dim sNewSQL As String 'variable to hold new sql statement during construction
    Dim sFile As String
    Dim sCustNum As String
    Dim sCustName As String
    Dim hr As Long
    Dim cWherePos As Long

    Set db = CurrentDb

    Set rsCustomers = db.OpenRecordset("qryCustomerList") 'open unique list of customers
    Set qdfReportData = db.QueryDefs("qryReportData_NEWDESC") ' get original query
    sOldSQL = Trim(qdfReportData.SQL)

    sOutputPathNEWDESC = Trim(sOutputPathNEWDESC)
    ' Default to the The Default Database Folder indicated in Tools, Options
    ' when no path was specified
    If Len(sOutputPathNEWDESC) = 0 Then
        sOutputPathNEWDESC = Application.GetOption("Default Database Directory") & "\"
        If Right(sOutputPathNEWDESC, 1) <> "\" Then sOutputPathNEWDESC = sOutputPathNEWDESC & "\"
    End If

    Do While Not rsCustomers.EOF 'loop through all customers and adjust query
        sCustNum = Nz(rsCustomers.Fields("cust").Value, "")
        sCustName = Nz(rsCustomers.Fields("custname").Value, "")

        sNewSQL = "SELECT * FROM qryReportData_Source_NEWDESC " _
                & "WHERE ([customer price list report source_tbl1].customer='" _
                & sCustNum & "')"

        qdfReportData.SQL = sNewSQL

        'sFile = sOutputPath & "\" & rsCustomers.Fields("cust") & ".xls"
        sFile = sOutputPathNEWDESC & _
                sCustNum & "_" & _
                sCustName & ".xls"

        'DoCmd.OutputTo acOutputReport, "Excel Cust Price List NEWDESC", acFormatXLS, sFile, False  'new report format
       DoCmd.OutputTo acOutputReport, "Excel Cust Price List NEWDESC1", acFormatXLS, sFile, False 'old report format



    qdfReportData.SQL = sOldSQL ' restore original sql statement

    'clean up objects
    Set qdfReportData = Nothing
    Set rsCustomers = Nothing

    Set db = Nothing
    MsgBox "Excel Files are Complete"

End Sub

Any thoughts, help?

Thank you
Ray ErdenBusiness Systems AnalystAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Don't output as a report.  Output the query.  It will be a clean export.  If you need to format it after the export, we can help with the OLE code necessary.  Access report exports to Excel and Word have never been acceptable and are  among the most useless features of an otherwise awesome product.
Ray ErdenBusiness Systems AnalystAuthor Commented:
Could you please provide me the OLE code to format the output file in Excel after the export?  All it needs to do is reformatting the Excel file  so the blank row right after the title row does not show and data on the sheet is not grouped.  

As a first option I would like to format the output file using the same process.  Otherwise I would try to output the query in fact I did try that but failed may need help wit that too.  If query output method is used the output location should not be hard coded in it as the user selects via browse button and VBA handles it that way.
Did you try to just export the query?  You probably don't need any code other than the TransferSpreadsheet.
Here's some sample code.  The first section determines which output needs to be formatted since this application exports multiple "reports" to Excel.  The second part shows you the concept of OLE automation.  You need to do what you need to do.  Use the code as a guide.  The other complication is early vs late binding.  This application needed to support multiple versions of Office because the company was in a period of transition.  Early binding is the best solution since it is easier to use during development and more efficient for execution.  However, it requires a fixed version of the Office application you are trying to automate and you need to set a reference to that version using the References dialog from the VBA editor.  If you have to support multiple versions, then you must use Late Binding which is inefficient since it provides no intellisense during development and requires Access to figure out what version of Excel (in this case) is installed so the code can bind to it.

                If Me.lstReports.Column(3) = "P-01" Then        'Weekly Job Status
                    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, Me.txtExcelQueryName, strFileName, False
                    Call FormatWeeklyJobStatus(strFileName)
                    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, Me.txtExcelQueryName, strFileName, True
                End If

Open in new window

Private Sub FormatWeeklyJobStatus(sFileName)

Const xlDown = -4121
Const xlCellTypeLastCell = 11
Const xlThemeFontMinor = 2
Const xlPrintNoComments = -4142
Const xlPortrait = 1
Const xlPaperLegal = 5
Const xlPaperLetter = 1
Const xlOverThenDown = 2
Const xlPrintErrorsDisplayed = 0
    Dim sPath           As String
    Dim sTemplateName   As String
    Dim lngRows           As Long       'MUST be long
Dim ref As Reference

' 0 if Late Binding
' 1 if Reference to Excel set.
#Const ExcelRef = 0
#If ExcelRef = 0 Then ' Late binding
    Dim appExcel As Object     'Excel Object
    Dim wbkNew As Object    'Workbook Object
    Dim wksNew As Object    'Sheet Object
    Dim wbkTemplate As Object   'Workbook Object for Template

    Set appExcel = CreateObject("Excel.Application")
    ' Remove the Excel reference if it is present   -   <=======
    On Error Resume Next
    Set ref = References!Excel
    If Err.Number = 0 Then
        References.Remove ref
    ElseIf Err.Number <> 9 Then 'Subscript out of range meaning not reference not found
        MsgBox Err.Description
        Exit Sub
    End If
' Use your own error handling label here
On Error GoTo FormatWeeklyJobStatus_Error
    ' a reference to MS Excel <version number> Object Library must be specified
    Dim appExcel As Excel.Application      'Excel Object
    Dim wbkNew As Excel.Workbook        'Workbook Object
    Dim wksNew As Excel.Worksheet       'Sheet Object
    Dim wbkTemplate As Excel.Workbook   'Workbook Object for Template

    Set appExcel = New Excel.Application
#End If

    On Error GoTo FormatWeeklyJobStatus_Error

    sPath = DLookup("Database", "MsysObjects", "[Name] = 'tblJob'")
    sPath = Left(sPath, InStrRev(sPath, "\"))
    sTemplateName = sPath & "WeeklyJobStatusHeaders.xlsx"

    Set wbkNew = appExcel.Workbooks.Open(sFileName)
    Set wksNew = appExcel.Worksheets("qWeeklyJobStatusReportExcel")
    'remove column names - some bug is preventing HasFieldNames argument from working on the export
    If wksNew.Range("A1").Value = "ContractName" Then
    End If
    ' Insert 5 rows at top to make room for headers
    With appExcel

        .Selection.Insert Shift:=xlDown
        .Selection.Insert Shift:=xlDown
        .Selection.Insert Shift:=xlDown
        .Selection.Insert Shift:=xlDown
        .Selection.Insert Shift:=xlDown
        ' Get headers from template file
        Set wbkTemplate = .Workbooks.Open(sTemplateName)
        ' Paste into new Workbook.
        ' Close template
        .CutCopyMode = False    'clear clipboard to get rid of warning message
        'add job name
        .Range("A5").Value = Me.cboJob.Column(3)
        ' Count rows in new Workbook.
        lngRows = .Selection.Row
        'insert sum functions
            'the reference style below uses the current position so we subtract the number of rows (lngRows)
            'to get to the top and then add 5 to get past the headers
        .Cells(lngRows + 1, 4).Select     'column D - Total plan pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
        .Cells(lngRows + 1, 5).Select     'column E - OFA pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
        .Cells(lngRows + 1, 6).Select     'column F - BFA pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
        .Cells(lngRows + 1, 7).Select     'column G - Issued to Shop pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
        .Cells(lngRows + 1, 9).Select     'column I - Cut Issue pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
        .Cells(lngRows + 1, 11).Select     'column K - Fitted pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
        .Cells(lngRows + 1, 12).Select     'column L - Welded pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
        .Cells(lngRows + 1, 13).Select     'column M - Shipped pieces
        .ActiveCell.FormulaR1C1 = "=SUM(R[" & -lngRows + 5 & "]C:R[" & -1 & "]C)"
        .Range("A" & lngRows + 1 & ":N" & lngRows + 1).Select
        ' Freeze panes
        .ActiveWindow.FreezePanes = True
        ' Header should print on every page when in Print Preview
        .ActiveSheet.PageSetup.PrintTitleRows = "$1:$5"
        .ActiveSheet.PageSetup.PrintTitleColumns = ""
       'format cells as numeric
        .Cells.NumberFormat = "#,##0_);[Red](#,##0)"
        ' Set format for date columns
        wksNew.Columns("H").NumberFormat = "d-mmm;@"
        wksNew.Columns("J").NumberFormat = "d-mmm;@"
        ' Set font and size
        With .Selection.Font
            .Name = "Calibri"
            .Size = 11
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .TintAndShade = 0
            .ThemeFont = xlThemeFontMinor
        End With
        ' Set page setup properties
        With .ActiveSheet.PageSetup
            .PrintArea = "$A$1:$N$" & CStr(lngRows + 2)
            .LeftHeader = ""
            .CenterHeader = ""
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = ""
            .RightFooter = ""
            .LeftMargin = appExcel.InchesToPoints(0.5)
            .RightMargin = appExcel.InchesToPoints(0.5)
            .TopMargin = appExcel.InchesToPoints(0.5)
            .BottomMargin = appExcel.InchesToPoints(0.5)
            .HeaderMargin = appExcel.InchesToPoints(0.5)
            .FooterMargin = appExcel.InchesToPoints(0.5)
            .PrintHeadings = False
            .PrintGridlines = True
            .PrintComments = xlPrintNoComments
           ' .PrintQuality = 600
            .CenterHorizontally = False
            .CenterVertically = False
            .Orientation = xlPortrait
            .Draft = False
            .PaperSize = IIf(lngRows > 44, xlPaperLegal, xlPaperLetter)
            .FirstPageNumber = xlAutomatic
            .Order = xlOverThenDown                         ' Change order to print all "page 1" before "page 2"
            .BlackAndWhite = False
            ''.Zoom = 80                                      ' Shrink down a little
            .Zoom = False                                   ' Should not need both
            .FitToPagesWide = 1
            .FitToPagesTall = False
            .PrintErrors = xlPrintErrorsDisplayed
        End With
    End With


    On Error Resume Next
    ' Required for cleanup.
    Exit Sub

    Select Case Err.Number
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FormatWeeklyJobStatus of VBA Document Form_frmReports"
    End Select

    Resume FormatWeeklyJobStatus_Exit
End Sub

Open in new window


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Ray ErdenBusiness Systems AnalystAuthor Commented:
I used transfer spreadsheet method by employing the below code for the line indicated as old format as stated in my original question's code block.  To make that code work I have created two new queries to generate the Excel output file with a clean format.  It worked good with this change.

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qryReportData_NEWDESC_Formatted", sFile, False
Ray ErdenBusiness Systems AnalystAuthor Commented:
Thank you Pat
You're welcome.  I'm glad you didn't actually need to get into OLE code to do what you needed.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.