Microsoft Access modExcel

Variables

Private xl As Excel.Application
Private blnCreated As Boolean

getExcel

Private Function getExcel(Optional blnVisible As Boolean = False) As Excel.Application
    If xl Is Nothing Then
        On Error Resume Next
        Set xl = GetObject(, "Excel.Application")
        On Error GoTo 0
        If xl Is Nothing Then
            Set xl = CreateObject("Excel.Application")
            xl.Visible = blnVisible
            blnCreated = True
        Else
            blnCreated = False
        End If
    End If
    
    Set getExcel = xl
End Function

quitExcel

Public Sub quitExcel()
    With xl
        If blnCreated Then
            .Quit
            blnCreated = False
        End If
    End With
End Sub

openExcelWorkbook

Public Function openExcelWorkbook(strPathFile As String) As Excel.Workbook
    Dim wbkResult As Excel.Workbook
    
    With getExcel
        Set wbkResult = .Workbooks.Open(strPathFile)
    End With
    
    Set openExcelWorkbook = wbkResult
End Function

closeExcelWorkbook

Public Sub closeExcelWorkbook(strWorkbook As String, Optional blnSave As Boolean = True, Optional blnQuit As Boolean = False)
    With xl
        With .Workbooks(strWorkbook)
            If blnSave Then
                .Save
            End If
            .Close SaveChanges:=False
        End With
        If blnQuit Then
            quitExcel
        End If
    End With
End Sub

applyCorporateStyle

Public Sub setExcelWorkbookFormat(strFilePath As String)
    Dim fso As FileSystemObject

    Dim xls As Excel.Application
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range

    Set fso = New FileSystemObject

    If Not fso.FileExists(strFilePath) Then
        MsgBox "The specified file does not exist."
        Exit Sub
    End If

    If Not Right(strFilePath, 4) = ".xls" Then
        MsgBox "The specified file is not a Microsoft Excel file."
        Exit Sub
    End If

    Set wbk = openExcelWorkbook(strFilePath)
    Set xls = wbk.Parent

    'Set default style
    With wbk.Styles("Normal").Font
        .Name = "Tahoma"
        .Size = 8
        .Bold = False
        .Italic = False
        .Underline = xlUnderlineStyleNone
        .Strikethrough = False
        .ColorIndex = xlAutomatic
    End With

    For Each wks In wbk.Worksheets
        With wks
            'Delete empty sheets
            If .UsedRange.Address = "$A$1" Then
                xls.DisplayAlerts = False
                .Delete
                xls.DisplayAlerts = True
            Else
                .Cells(2, 1).Select

                'Remove gridlines and freeze pane
                With xls.ActiveWindow
                    .DisplayGridlines = False
                    .FreezePanes = True
                End With

                'Borders
                With .UsedRange
                    .Borders(xlDiagonalDown).LineStyle = xlNone
                    .Borders(xlDiagonalUp).LineStyle = xlNone
                    With .Borders(xlEdgeLeft)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = 2
                    End With
                    With .Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = 2
                    End With
                    With .Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = 2
                    End With
                    With .Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = 2
                    End With
                    With .Borders(xlInsideVertical)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = 2
                    End With
                    With .Borders(xlInsideHorizontal)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = 2
                    End With
                End With

                'Format first row
                Set rng = .UsedRange.Rows(1)
                With rng
                    .Font.Bold = True
                    .Font.Color = vbWhite
                    .Interior.Color = vbRed

                    'Enable AutoFilter
                    If wks.AutoFilterMode = False Then
                        .AutoFilter
                    Else
                        .AutoFilter
                        .AutoFilter
                    End If

                End With
                
                'Adjust column widths
                .UsedRange.Columns.AutoFit
            End If

            'Number formatting
            For Each rng In .UsedRange.EntireColumn.Columns

                'First row values
                With rng.Cells(2, 1)
                    
                    'Alignment
                    rng.IndentLevel = 1
                    Select Case VarType(.Value)
                    Case vbString, vbBoolean, vbVariant
                        rng.HorizontalAlignment = xlLeft
                    Case vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDate, vbDecimal
                        rng.HorizontalAlignment = xlRight
                    Case Else
                        '...
                    End Select
                    
                    'Number Format
                    Select Case VarType(.Value)
                    Case vbBoolean
                        rng.NumberFormat = "[=-1]""yes"";[=0]""no"";"
                    Case vbInteger, vbLong
                        rng.NumberFormat = "#,##0;[red]#,##0;-"
                    Case vbSingle, vbDouble, vbCurrency, vbDecimal
                        rng.NumberFormat = strFormatCurrency
                    Case vbDate
                        rng.NumberFormat = strFormatDate
                    Case Else
                        '...
                    End Select
                    
'                    If IsNumeric(.Value) Then
'                        With rng
'                            .HorizontalAlignment = xlRight
'                            .IndentLevel = 1
'                            .NumberFormat = strFormatCurrency
'                        End With
'                    Else
'                        With rng
'                            .HorizontalAlignment = xlLeft
'                            .IndentLevel = 1
'                        End With
'                    End If
'
'                    If IsDate(.Value) Then
'                        With rng
'                            .HorizontalAlignment = xlRight
'                            .IndentLevel = 1
'                            .NumberFormat = strFormatDate
'                        End With
'                    End If
                    
                End With
            Next
            
            'Adjust column widths
            .UsedRange.Columns.AutoFit
        End With
    Next

    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

subTotalColumn

Public Sub subTotalColumn( _
    strFilePath As String, _
    strWorksheet As String, _
    ParamArray arrColumnName() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range
    
    Dim varColumnName As Variant
    Dim rngFormula As Range
    Dim rngSum As Range
    Dim intRow As Integer
 
    Set wbk = openExcelWorkbook(strFilePath)
    Set wks = wbk.Worksheets(strWorksheet)
    With wks
        
        intRow = .UsedRange.Rows.Count
        
        'Add lines for sub totals
        .Rows("1:1").Insert Shift:=xlDown
        .Rows("1:1").Insert Shift:=xlDown
        .Rows("1:1").Insert Shift:=xlDown
        
        intRow = intRow + 3
        
        For Each varColumnName In arrColumnName
        
            Set rngFormula = .Rows(4).Find( _
                What:=varColumnName).Offset(-2, 0)
            
            Set rngSum = .Range( _
                .Cells(5, rngFormula.column), _
                .Cells(intRow, rngFormula.column))
            
            Debug.Print
            Debug.Print "UsedRg : " & .UsedRange.Rows.Count
            Debug.Print "intRow : " & intRow
            Debug.Print "rngSum : " & rngSum.Address
            Debug.Print
            
            If IsNumeric(rngSum.Cells(1, 1)) Then
                rngFormula.Formula = _
                    "=SUBTOTAL(9," & rngSum.Address & ")"
            Else
                rngFormula.Formula = _
                    "=SUBTOTAL(3," & rngSum.Address & ")"
                rngFormula.NumberFormat = "0 ""Receipts"""
            End If
        Next
        
    End With
    
    rngFormula.EntireRow.Font.Bold = True
    
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

sumColumn

Public Sub sumColumn( _
    strFilePath As String, _
    strWorksheet As String, _
    ParamArray arrColumn() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range
    
    Dim varIndex As Variant
    Dim rngSum As Range
    Dim intRow As Integer
 
    Set wbk = openExcelWorkbook(strFilePath)
    Set wks = wbk.Worksheets(strWorksheet)
    With wks
        intRow = .UsedRange.Rows.Count
        For Each varIndex In arrColumn
            Set rngSum = .Range( _
                .Cells(1, varIndex), _
                .Cells(intRow, varIndex))
            rngSum.Cells(intRow, 1).Offset(2, 0).Formula = "=SUM(" & rngSum.Address & ")"
        Next
    End With
    
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

formatColumnNumber

Public Sub formatColumnNumber( _
    strFilePath As String, _
    strWorksheet As String, _
    strNumberFormat As String, _
    ParamArray arrColumn() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range
    
    Dim varIndex As Variant
 
    Set wbk = openExcelWorkbook(strFilePath)
    Set wks = wbk.Worksheets(strWorksheet)
    With wks
        For Each varIndex In arrColumn
            .Columns(varIndex).NumberFormat = strNumberFormat
        Next
    End With
    
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

formatColumnBackground

Public Sub formatColumnBackground( _
    strFilePath As String, _
    strWorksheet As String, _
    lngColor As Long, _
    ParamArray arrColumn() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range
    
    Dim intRow As Integer
    Dim varIndex As Variant
 
    Set wbk = openExcelWorkbook(strFilePath)
    Set wks = wbk.Worksheets(strWorksheet)
    With wks
        intRow = .UsedRange.Rows.Count
        For Each varIndex In arrColumn
            .Range( _
                Cells(2, varIndex), _
                Cells(intRow, varIndex) _
            ).Interior.Color = lngColor
        Next
    End With
    
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub