Excel Reports Setup using VBA Macros

Similar to the prior blog post about standard footers in Word documents, I also created a VBA Macro for Excel which defines my print area, adds headers and footers to the printed pages, sets the first row to repeat on all pages, and add colors to the first row in the spreadsheet (titles).   It also sets the width of all the columns based on the width of the data within the column.

The variables RangeToPrint and HeadingsAtTop are automatically calculated at the time the macro is run - so it works with spreadsheet worksheets of all sizes and shapes.

Here is the code:

Sub StandardReportLayout()
'
' StandardReportLayout Macro
' Autowidth Columns and color top header
'
Dim x As Long, lastCell As Range, RangeToPrint As Range, HeadingsAtTop As Range
x = ActiveSheet.UsedRange.Columns.Count
Set lastCell = Cells.SpecialCells(xlCellTypeLastCell)
Set HeadingsAtTop = Range(Cells(1, 1), Cells(1, x))
Set RangeToPrint = Range(Cells(1, 1), lastCell)

'
    HeadingsAtTop.Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = True
    ActiveWindow.LargeScroll ToRight:=0
    Range("A1").Select
    Selection.End(xlToRight).Select
    Range(Selection, Cells(ActiveCell.Row, 1)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    RangeToPrint.Select
    
    Selection.Columns.AutoFit
    ActiveWindow.LargeScroll ToRight:=-1
    Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Columns.AutoFit
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    ActiveSheet.PageSetup.PrintArea = RangeToPrint.Address
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
   
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = RangeToPrint.Address
    
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = "&Z&F  &A"
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = "Page &P of &N  - &D  &T"
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .PrintHeadings = False
        .PrintGridlines = True
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
End Sub

Automatic Footers in Word using VBA Macros

I'm in a new office environment in which I'm generating lots of data reports.  One of the things I have found frustrating in other environments is being handed a printed copy of a report and having no idea where the original electronic version is stored. 

This VBA macro can be used to set up a standard footer in your Word documents which includes the full path and filename for the report as well as the current page out of total pages.

Now each time I create a report, I have a simple macro to run which creates a standard footer which shows others where to find the electronic version of my printed reports.


Here is the code

Sub InsertFooter()
' InsertFooter Macro
' Insert a File Footer with filename and page numbers

If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
    ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow.ActivePane.View.Type = wdOutlineView Then
    ActiveWindow.ActivePane.View.Type = wdPrintView
End If
'Set the footer
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Selection.Font.Size = 9
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="FILENAME  \p ", PreserveFormatting:=True
Selection.TypeText Text:=vbTab
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="PAGE  ", PreserveFormatting:=True
Selection.TypeText Text:=" of "
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="NUMPAGES  ", PreserveFormatting:=True
End Sub