Private xl As Excel.Application
Private blnCreated As Boolean
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
Public Sub quitExcel()
With xl
If blnCreated Then
.Quit
blnCreated = False
End If
End With
End Sub
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
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
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
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
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
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
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