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 applyCorporateStyle(strFile 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(strFile) Then
        MsgBox "The specified file does not exist."
        Exit Sub
    End If
    
    If Not Right(strFile, 4) = ".xls" Then
        MsgBox "The specified file is not a Microsoft Excel file."
        Exit Sub
    End If
    
    Set wbk = openExcelWorkbook(strFile)
    Set xls = wbk.Parent
    
    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
                .Activate

                'Remove gridlines and freeze pane
                .Cells(2, 1).Select
                With xls.ActiveWindow
                    .DisplayGridlines = False
                    .FreezePanes = True
                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 .Columns
                
                'First row values
                With rng.Cells(2, 1)
                    If IsDate(.Value) Then
                        rng.NumberFormat = strFormatDate
                    ElseIf IsNumeric(.Value) Then
                        rng.NumberFormat = strFormatCurrency
                    End If
                End With
            Next

        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