Creating a formatted Excel Worksheet with header from MS Access 2010

Hello,
I need to create a formatted excel worksheet with a header.
The header information can come from the form with a button I am using to generate the worksheet.
The body of the worksheet needs to come from a query.
Thanks for any help
iainmacleodAsked:
Who is Participating?
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.

iainmacleodAuthor Commented:
Thanks Rey, that is really useful. I am struggling to be able to insert Rows at the top of the Worksheet to then allow me to add the headers.
Can you help...?
Thanks
0
Rey Obrero (Capricorn1)Commented:
post the codes you are using
0
PatHartmanCommented:
Here is code that exports the data and then formats it.  The sub uses late binding because users had different versions of Access and Office.  It removes the column headers which seemed to be exported even when the property on the TransferSpreadsheet was set to False.  Looks like some kind of bug to watch out for.  Then it inserts 5 rows to make room for headers and puts them there.

            DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, Me.txtExcelQueryName, strFileName, False
            Call FormatWeeklyJobStatus(strFileName)



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
#Else
    ' 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
        appExcel.Rows("1:1").Select
        appExcel.Rows("1:1").Delete
    End If
    
    ' Insert 5 rows at top to make room for headers
    With appExcel

        .Rows("1:1").Select
        .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)
        wbkTemplate.Activate
        .Rows("1:5").Select
        .Selection.Copy
        
        ' Paste into new Workbook.
        wbkNew.Activate
        .ActiveSheet.Paste
        
        ' Close template
        .CutCopyMode = False    'clear clipboard to get rid of warning message
        wbkTemplate.Close
        
        'add job name
        .Range("A5").Value = Me.cboJob.Column(3)
        
        ' Count rows in new Workbook.
        .Selection.SpecialCells(xlCellTypeLastCell).Select
        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
        .Range("A6").Select
        .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
        .Cells.Select
        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
        .Columns("A:N").Select
        .Selection.Columns.AutoFit
        
        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

    wbkNew.Save

FormatWeeklyJobStatus_Exit:
    On Error Resume Next
    ' Required for cleanup.
    wbkNew.Close
    Exit Sub

FormatWeeklyJobStatus_Error:
    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

0

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
iainmacleodAuthor Commented:
Many thanks for your help
0
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.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.