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

setExcelWorkbookFormat

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
                .Activate
                .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
                End With
            Next
            
            'Adjust column widths
            .UsedRange.Columns.AutoFit
        End With
    Next

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

createExcelColumnSubTotal

Public Sub createExcelColumnSubTotal( _
    strFilePath 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)
    For Each wks In wbk.Worksheets
        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 = Nothing
                Set rngSum = Nothing
                
                On Error Resume Next
                Set rngFormula = .Rows(4).Find( _
                    What:=varColumnName).Offset(-2, 0)
                
                If Not rngFormula Is Nothing Then
                    rngFormula.EntireRow.Font.Bold = True
                    Set rngSum = .Range( _
                        .Cells(5, rngFormula.column), _
                        .Cells(intRow, rngFormula.column))
                End If
                On Error GoTo 0
    
                If Not rngSum Is Nothing Then
                    If IsNumeric(rngSum.Cells(1, 1)) Then
                        With rngFormula
                            .Formula = _
                                "=SUBTOTAL(9," & rngSum.Address & ")"
                            .HorizontalAlignment = xlRight
                        End With
                    Else
                        With rngFormula
                            .Formula = _
                                "=SUBTOTAL(3," & rngSum.Address & ")"
                            .NumberFormat = "[=0]""No Records"";[=1]0 ""Record"";0 ""Records"""
                            .HorizontalAlignment = xlLeft
                        End With
                    End If
                End If
            Next
    
        End With
    Next
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

createExcelColumnSum

Public Sub createExcelColumnSum( _
    strFilePath As String, _
    ParamArray arrColumn() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range

    Dim varColumn As Variant
    Dim intColumn As Integer
    Dim rngSum As Range
    Dim intRow As Integer

    Set wbk = openExcelWorkbook(strFilePath)
    For Each wks In wbk.Worksheets
        With wks
            intRow = .UsedRange.Rows.Count
            For Each varColumn In arrColumn
                intColumn = getExcelColumnNumber(wks, varColumn)
                If intColumn > 0 Then
                    Set rngSum = .Range( _
                        .Cells(1, intColumn), _
                        .Cells(intRow, intColumn))
                    rngSum.Cells(intRow, 1).Offset(2, 0).Formula = "=SUM(" & rngSum.Address & ")"
                End If
            Next
        End With
    Next
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

setExcelColumnNumberFormat

Public Sub setExcelColumnNumberFormat( _
    strFilePath As String, _
    strNumberFormat As String, _
    ParamArray arrColumn() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range

    Dim varColumn As Variant
    Dim intColumn As Integer

    Set wbk = openExcelWorkbook(strFilePath)
    For Each wks In wbk.Worksheets
        With wks
            For Each varColumn In arrColumn
                intColumn = getExcelColumnNumber(wks, varColumn)
                If intColumn > 0 Then
                    With .Columns(intColumn)
                        .NumberFormat = strNumberFormat
                        .HorizontalAlignment = xlRight
                    End With
                End If
            Next
            .UsedRange.Columns.AutoFit
        End With
    Next

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

setExcelColumnBackground

Public Sub setExcelColumnBackground( _
    strFilePath As String, _
    lngColor As Long, _
    ParamArray arrColumn() _
    )
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim rng As Range

    Dim intRowCount As Integer
    Dim varColumn As Variant
    Dim intColumn As Integer

    Set wbk = openExcelWorkbook(strFilePath)
    For Each wks In wbk.Worksheets
        With wks
            intRowCount = .UsedRange.Rows.Count
            For Each varColumn In arrColumn
                intColumn = getExcelColumnNumber(wks, varColumn)
                If intColumn > 0 Then
                    .Range( _
                        Cells(2, intColumn), _
                        Cells(intRowCount, intColumn) _
                    ).Interior.Color = lngColor
                End If
            Next
        End With
    Next
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

setExcelRowBackground

Public Sub setExcelRowBackground( _
    strFilePath As String, _
    lngColor As Long, _
    varColumn As Variant, _
    strColumnWhere As String _
    )
    Dim xl As Excel.Application
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim intColumn As Integer
    Dim rng As Range

    Set wbk = openExcelWorkbook(strFilePath)
    Set xl = wbk.Parent
    For Each wks In wbk.Worksheets
        intColumn = getExcelColumnNumber(wks, varColumn)
        If intColumn > 0 Then
            For Each rng In xl.Intersect(wks.Columns(intColumn), wks.UsedRange).Cells
                With rng
                    If .Value = strColumnWhere Then
                        xl.Intersect(.EntireRow, wks.UsedRange).Interior.Color = lngColor
                    End If
                End With
            Next
        End If
    Next
    closeExcelWorkbook strWorkbook:=wbk.Name, blnSave:=True
End Sub

getExcelColumnNumber

Private Function getExcelColumnNumber(wks As Worksheet, varColumn As Variant) As Integer
    Dim intResult As Integer
    
    Dim rng As Range
    
    Select Case VarType(varColumn)
    Case vbString
        Set rng = wks.Cells.Find(CStr(varColumn))
        If Not rng Is Nothing Then
            intResult = rng.column
        End If
    Case vbInteger
        intResult = CInt(varColumn)
    Case Else
        MsgBox "Huh?"
    End Select
    
    getExcelColumnNumber = intResult
End Function