Thursday, December 3, 2009

Excel & VBA Auto-formatting report

This is my first "developped-from-scratch" VBA script.

Sub FormatReport()

'Add total footer
Dim lastRow As Integer
Dim lastCol As Integer

lastRow = [A65536].End(xlUp).Row + 1
lastCol = [VV1].End(xlToLeft).Column

Range(Cells(lastRow, 1), Cells(lastRow, 1)).Value = "TOTAL"

Dim col As Integer
col = 2
Do Until col = lastCol
Range(Cells(lastRow, col), Cells(lastRow, col)).Select
R = ActiveCell.Row
C = ActiveCell.Column
If IsNumeric(Cells(2, C)) And Not IsEmpty(Cells(2, c)) Then
ActiveCell.Value = Application.sum(Range(Cells(2, C), Cells(R, C)))
End If
col = col + 1
Loop

'Format cells
col = 2
Do Until col = lastCol
'Range("B2", Cells(lastRow, lastCol)).Select
Range(Cells(2, col), Cells(lastRow, col)).Select
If IsNumeric(Cells(2, col)) Then
Selection.NumberFormat = "$#,##0"
End If
If IsDate(Cells(2, col)) Then
Selection.NumberFormat = "m/d/yyyy"
End If
Cells.EntireColumn.AutoFit
col = col + 1
Loop

'Format footer
Range(Cells(lastRow, 1), Cells(lastRow, lastCol)).Select
With Selection.Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 2
Selection.Font.Bold = True

'Format header
Range(Cells(1, 1), Cells(1, lastCol)).Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 2
Range(Cells(1, 2), Cells(1, lastCol)).Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

'Insert new row
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range(Cells(1, 1), Cells(1, lastCol)).Select
With Selection.Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 2
Selection.Font.Bold = True
Range(Cells(1, 1), Cells(1, lastCol)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge

'Add header to new row
Dim month As String
month = Application.InputBox("Enter Month and Year for the report header", "Enter Date", "January 2009")

Range(Cells(1, 1), Cells(1, lastCol)).Select
ActiveCell.FormulaR1C1 = "REPORT FOR " + month
Range(Cells(1, 1), Cells(1, lastCol)).Select
With Selection.Font
.Name = "Arial"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With

End Sub

No comments:

Post a Comment