Access VBA

css navigation by Css3Menu.com

Export Formatted Spreadsheet

My customer was calling everyday saying, ‘I know you showed me how to expand the columns and print the file, but I forgot’. Well that go old in a hurry. Everything on his menu that creates a spreadsheet now calls this routine from an additional line added to the report VBA: FormatXLfile CurPath, 4 Where CurPath is path and filename and the number is the type and title in Excel.
Sub FormatXLfile(daPath As String, RptN As String)
    Dim XLapp   As Object
    Dim WB      As Object
    Dim WS      As Object
    Dim LastC   As Long
    Dim LastR   As Long
    Dim A       As Long
    Dim RptTp   As String
    
    Set XLapp = CreateObject("excel.Application")
    Set WB = XLapp.Workbooks.Open(daPath)
    Select Case RptN
        Case 1
            RptTp = " Paid Members"
        Case 2
            RptTp = " Not Paid and Not Dropped"
        Case 3
            RptTp = "Members for Printer"
        Case 4
            RptTp = "Digital Members"
        Case Else
            RptTp = "GPS Unknown"
    End Select
    XLapp.ScreenUpdating = True
    XLapp.Visible = True
    Set WS = WB.Sheets(1)
    WS.Activate 
    '-------------------------------------------
    WS.Cells(1, 1).Select
    LastC = WS.Cells(1, 2000).End(xlToLeft).Column
    LastR = WS.Range("A65000").End(xlUp).Row
    Debug.Print "Row: " & LastR & " Col: " & LastC
    With WS
        .Cells.Select
        .Cells.EntireColumn.AutoFit
        .Cells(1, 1).Select
        .Range(.Cells(1, 1), .Cells(1, LastC)).Select
        .Range(.Cells(1, 1), .Cells(1, LastC)).Font.Bold = True
        .Activate
         With .Range(.Cells(1, 1), .Cells(1, LastC)).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 49407
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    
    .Cells(1, 1).Select
    With WS.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    With WB.ActiveSheet.PageSetup.PrintArea = "$A$2:" & .Cells(LastR, LastC).Address
        
     '----------------------- Print Setup -------------
    With WS.PageSetup
        .LeftHeader = ""
        .CenterHeader = RptTp
        .RightHeader = "&D  &T"
        .LeftFooter = "Confidential Information"
        .CenterFooter = ""
        .RightFooter = "Page &P of &N"
        .Zoom = False
        
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .LeftMargin = XLapp.InchesToPoints(0.2)
        .RightMargin = XLapp.InchesToPoints(0.2)
        .TopMargin = XLapp.InchesToPoints(0.7)
        .BottomMargin = XLapp.InchesToPoints(0.7)
        .HeaderMargin = XLapp.InchesToPoints(0.2)
        .FooterMargin = XLapp.InchesToPoints(0.2)
        .PrintHeadings = False
        .PrintGridlines = True
        .PrintQuality = 600
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLetter  'Legal ?
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False

    End With
 '   Stop       'Never got this to work
'         Range("B2").Select
'    ActiveWindow.FreezePanes = True
    End With
    End With
    WB.Save
    WB.Close
    Set WB = Nothing
    Set XLapp = Nothing
   
End Sub



Here is the code from the menu to export the Access data to Excel and call the function to make the spreadsheet pretty and ready to print.

Because this spreadsheet is usually 10-15 columns, I am considering an inputbox to ask if user wants to choose Letter or Legal size paper.

    CurPath = "C:\USERS\" & Environ("USERNAME") & "\Desktop\" & Format(Now(), "yyyymmdd") & "_UT_Digital_Export.xlsb"	Writes to desktop
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "qryMailing4Digital", CurPath, -1
    FormatXLfile CurPath, 4  Call the FormatXLFile routine shown above

Cut me driving 15 miles each way to show him how to set headings in Excel.

© MMXX

Updated:  09/25/2020 10:49
This page added:  25 September 2020