Option Explicit
Private Const Wages As Long = 6120110
Private Const Merit As Long = 6120807
Private Const Fica As Long = 6120605
Private Const Benefits As Long = 6030610
Private Const Contingent As Long = 6130202
Public Sub HandleGLAndContingentWorksheets()
Dim wb As Workbook
Dim ws As Worksheet, mst As Worksheet, mstTemp As Worksheet
Dim numericPart As String, char As String
Dim i As Integer, x As Integer, wsCnt As Integer
Dim lr As Long, monRow As Long, expRow As Long, hasGLNum As Long
Dim rng As Range, cRow As Range, fillRangeRow As Range, target As Range
Dim ar As Variant
Dim sumMonths(1 To 12) As Double, contTest As Double
Dim writeContingent As Boolean
Dim GLFilePath As String
Dim TotalCost As Double
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set mst = ThisWorkbook.Sheets("Master")
'File Dialog Box
GLFilePath = Application.GetOpenFilename(FileFilter:="Excel files (*.xlsx*), *.xlsx*", Title:="Choose an Excel file to open", MultiSelect:=False)
If GLFilePath = "False" Then Exit Sub
'clear master template
mst.UsedRange.Clear
Set wb = Workbooks.Open(GLFilePath)
' add a temp mst to put all value to prior transfer to Master
On Error Resume Next
wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)).Name = "mstTemp"
On Error GoTo 0
Set mstTemp = wb.Sheets("mstTemp")
For Each ws In wb.Worksheets
numericPart = ""
For i = 1 To Len(ws.Name)
char = Mid(ws.Name, i, 1)
If IsNumeric(char) Then
numericPart = numericPart & char
End If
Next
If IsNumeric(numericPart) And Len(numericPart) = 6 Then
With ws
' for testing...don't uncomment this line
'.Columns("A:B").Delete Shift:=xlToLeft
' check for filter ON
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
' insert column and make text type to handle 000000
.Columns("A:B").Insert Shift:=xlToRight
.Columns("A:A").NumberFormat = "@"
' set working range
lr = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng = .Range("D2:P" & lr)
' add sheet name
.Range("A2:A" & lr).Value = "'" & numericPart
' loop through and sum expense
For Each cRow In ws.Range("D2:D" & lr).Rows
Set target = cRow.Cells(, 1)
' add the GL Codes
If InStr(1, target.Value, "Wages", vbTextCompare) > 0 Then hasGLNum = Wages
If InStr(1, target.Value, "Merit", vbTextCompare) > 0 Then hasGLNum = Merit
If InStr(1, target.Value, "Fica", vbTextCompare) > 0 Then hasGLNum = Fica
If InStr(1, target.Value, "Benefits", vbTextCompare) > 0 Then hasGLNum = Benefits
' switch contingent tracking
If InStr(1, target.Value, "Total FTEs", vbTextCompare) > 0 Then writeContingent = True
If InStr(1, target.Value, "Wages", vbTextCompare) > 0 Then writeContingent = False
' mark the contingent lines
If writeContingent And InStr(1, target.Value, "Contingent", vbTextCompare) > 0 Then
cRow.Cells(, -1).Value = "contingent"
End If
' find the month row
If Trim(target.Offset(, 1).Value) = "Jan" Then
monRow = cRow.Row + 1
End If
' find expense
If Trim(target.Value) = "Expense" Then
expRow = cRow.Row
If hasGLNum > 0 Then target.Offset(, -1).Value = hasGLNum
End If
' if we have both, put sum, fill across
If monRow > 0 And expRow > 0 Then
Set fillRangeRow = ws.Range(ws.Cells(expRow, 5), ws.Cells(expRow, 16))
fillRangeRow.Formula = "=SUM(E" & monRow & ":E" & expRow - 1 & ")"
monRow = 0
expRow = 0
hasGLNum = 0
End If
' if we need to write GL do it
If hasGLNum > 0 Then target.Offset(, -1).Value = hasGLNum
Next
'Figure out how to grab Total cost
TotalCost = TotalCost + Application.WorksheetFunction.Max(.Range("Q:Q"))
' initialize the array
For x = 1 To 12
sumMonths(x) = 0
Next
' add contingent values
For i = 1 To .UsedRange.Rows.Count
If .Cells(i, "B").Value = "contingent" Then
For x = 5 To 16
If IsNumeric(ws.Cells(i, x).Value) Then
sumMonths(x - 4) = sumMonths(x - 4) + ws.Cells(i, x).Value
End If
Next
End If
Next
' delete contingent
For i = ws.UsedRange.Rows.Count To 1 Step -1
If InStr(1, ws.Range("D" & i).Value, "Contingent", vbTextCompare) > 0 Then
ws.Cells(i, 1).EntireRow.Delete
End If
Next
'overwrite with just values
With .UsedRange
.Value = .Value
End With
' copy expenses to master temp
lr = mstTemp.Cells(.Rows.Count, "A").End(xlUp).Row + 1
mstTemp.Columns("A:A").NumberFormat = "@"
For i = 1 To .UsedRange.Rows.Count
If InStr(1, ws.Range("D" & i).Value, "Expense", vbTextCompare) > 0 And ws.Range("C" & i).Value <> "" _
And ws.Range("Q" & i).Value <> 0 Then
Set fillRangeRow = ws.Range(ws.Cells(i, 1), ws.Cells(i, 16))
Set rng = mstTemp.Cells(lr, 1)
Set rng = rng.Resize(1, fillRangeRow.Columns.Count)
rng.Value = fillRangeRow.Value
lr = lr + 1
End If
Next
' copy contingent to master file
contTest = 0
For x = 1 To 12
contTest = contTest + sumMonths(x)
Next
If contTest <> 0 Then
With mstTemp
lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & lr).Value = numericPart
.Range("C" & lr).Value = Contingent
.Range("D" & lr).Value = "Contingent"
For x = 1 To 12
.Cells(lr, x + 4).Value = sumMonths(x)
Next
End With
End If
End With
' count ws success
wsCnt = wsCnt + 1
End If
numericPart = ""
Next
' clean up msttemp
With mstTemp
.Cells(, 2).EntireColumn.Delete
.Rows("1:2").Insert Shift:=xlDown
.Range("A1:E1").Merge
.Range("A1").Value = "Ws Success Count: " & wsCnt & Space(10) & Format(Now(), "mm/dd/yyyy hh:mm:ss AM/PM")
.Range("A3:O3").Value = Array("Cost Center: Code", "GL Account", "Staffing Type", "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
.Columns("A:A").NumberFormat = "@"
.Range("C:C").Replace What:="Expense", Replacement:="Job"
End With
' copy to masterfile
ar = mstTemp.UsedRange.Value
mst.UsedRange.Clear
mst.Columns("A:A").NumberFormat = "@"
Set rng = mst.Range("A1").Resize(UBound(ar, 1), UBound(ar, 2))
rng.Value = ar
' some formmating
With mst
.Rows("3").Font.Bold = True
.Range("A:O").HorizontalAlignment = xlRight
.Columns("A:O").AutoFit
.Range("D:O").NumberFormat = "_(* #,##0.00_);_(* -#,##0.00;_(* """"??_);_(@_)"
End With
'Copy Total Cost to Master and subtract from template total
mst.Range("G1") = Round((WorksheetFunction.Sum(Range("D:O")) - TotalCost), 1)
' delete the mstTemp sheet
mstTemp.Delete
' close the wb
wb.Close SaveChanges:=False
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set wb = Nothing
Set ws = Nothing
Set mst = Nothing
Set mstTemp = Nothing
'Fill Cell Color
If ActiveSheet.Range("G1") = 0 Then
ActiveSheet.Range("G1").Interior.Color = vbGreen
Else
ActiveSheet.Range("G1").Interior.Color = vbRed
End If
'Complete or Error Message
If ActiveSheet.Range("G1") = 0 Then
MsgBox "Macro Complete", , "YOUR DATA IS COMPLETE"
Else
MsgBox "Total Cost Does Not Reconcile", , "Error"
End If
End Sub
