payroll_allocation.vba

' David DeMar
' dfdemar@gmail.com

Sub FormatData()
'
' FormatData Macro
' Removes merged cells and wrapped text from the Payroll Summary report and checks that all employees are included in the allocations sheet
'

'
    Sheets("Payroll_Summary").Select
    Cells.Select
    Selection.UnMerge
    With Selection
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.Select
    Selection.WrapText = True
        With Selection
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Cells.Select
    Selection.WrapText = False
        With Selection
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With


    Columns("B:B").Select
    Selection.Copy
    Sheets("Employees").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$A$500").RemoveDuplicates Columns:=1, header:=xlNo
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Allocations!C[-1],1,FALSE)"
    Range("B1").Select
    Selection.AutoFill Destination:=Range("B1:B500")
    Range("B1:B500").Select
End Sub


Sub PopulatePayAllocations()
    Dim payrollSummaryWs As Worksheet
    Dim lastRow As Long, lastCol As Long, employeeCount As Long, payTypeCount As Long
    Dim endDataCol As String

    Dim allocationsWs As Worksheet
    Dim employee As String
    Dim payType As String
    Dim payValue As Double

    Set payrollSummaryWs = Worksheets("Payroll_Summary")
    Set allocationsWs = Worksheets("Allocations")

    lastRow = payrollSummaryWs.Cells(payrollSummaryWs.Rows.Count, "A").End(xlUp).Row
    ' Subtract 1 to get the last column before the "Total" column
    lastCol = payrollSummaryWs.Cells(1, payrollSummaryWs.Columns.Count).End(xlToLeft).Column - 1
    endDataCol = Split(allocationsWs.Cells(1, lastCol).Address, "$")(1)

    ' Subtract 1 to exclude the header row
    employeeCount = lastRow - 1

    ' Subtract 1 to exclude the "Total" column
    payTypeCount = lastCol - 1

    Dim data() As Variant
    ReDim data(1 To employeeCount * payTypeCount, 1 To 3)

    Dim employeeCell As Range
    Dim payrollCell As Range
    Dim index As Integer
    index = 1

    ' Loop over each employee
    For Each employeeCell In payrollSummaryWs.Range("A2:A" & lastRow)
        ' Loop over all the payroll types (e.g. wages, taxes, benefits, etc) for the employee
        For Each payrollCell In payrollSummaryWs.Range("B" & employeeCell.Row & ":" & endDataCol & employeeCell.Row)
            If Not IsEmpty(employeeCell.Value) And payrollCell.Value <> "0" Then
                payType = payrollSummaryWs.Cells(1, payrollCell.Column).Value
                payValue = payrollCell.Value

                data(index, 1) = employeeCell.Value
                data(index, 2) = payType
                data(index, 3) = payValue
                index = index + 1
            End If
        Next payrollCell
    Next employeeCell

    allocationsWs.Range("A3:C" & index - 1).Value = data

    WageCalculation
End Sub


Sub WageCalculation()
    ' WageCalculation Macro
    '
    ' This will create the formulas for payroll items, sum them up, add up the rows in
    ' the Total Percentage column, and conditionally format the totals

    ' Define the Payroll Summary worksheet
    Dim payrollSummaryWs As Worksheet
    Set payrollSummaryWs = Worksheets("Payroll_Summary")

    ' Calculate the last column in the Payroll Summary worksheet
    Dim psLastCol As Long
    psLastCol = payrollSummaryWs.Cells(1, payrollSummaryWs.Columns.Count).End(xlToLeft).Column

    ' Calculate the number of pay types by excluding the "Staff" and "Total" columns
    Dim payTypeCount As Long
    payTypeCount = psLastCol - 2

    ' Define the Allocations worksheet
    Dim allocationsWs As Worksheet
    Set allocationsWs = Sheets("Allocations")

    ' Last row and column of data
    Dim lastRow As Long, lastCol As Long

    ' Name of last column in the range of percentage data to be summed
    Dim endDataCol As String
    ' Name of the Total Percentage column
    Dim totalPercentageCol As String

    ' Create the formulas for payroll items
    With allocationsWs
        ' Find the last row of data
         lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        Dim offset As Long
        offset = 3

        Dim i As Long
        For i = 0 To payTypeCount - 1
            .Range("C" & i + offset).FormulaR1C1 = "=SUMIF(Payroll_Summary!C[-2],Allocations!RC[-2],Payroll_Summary!C[" & i - 1 & "])"
        Next i

        .Range("C" & offset & ":C" & payTypeCount + 2).AutoFill Destination:=.Range("C" & offset & ":C" & lastRow)

        ' Find the last column
        lastCol = .Cells(3, .Columns.Count).End(xlToLeft).Column

        ' Get the column names for the "Total Percentage" column and the last column of data
        totalPercentageCol = Split(.Cells(1, lastCol).Address, "$")(1)
        endDataCol = Split(.Cells(1, lastCol - 1).Address, "$")(1)

        ' Sum the rows in the "Total Percentage" column
        .Range(totalPercentageCol & "3").FormulaR1C1 = "=SUM(RC4:RC[-1])"
        .Range(totalPercentageCol & "3:" & totalPercentageCol & lastRow).FillDown

        ' Format the total column
        With .Columns(totalPercentageCol & ":" & totalPercentageCol)
            .NumberFormat = "0.00%"
            .FormatConditions.Delete ' Clear existing format conditions

            ' Greater than 100% condition
            With .FormatConditions.Add(Type:=xlCellValue, Operator:=xlGreater, Formula1:="=1")
                .SetFirstPriority
                .Font.Color = -16383844
                .Interior.Color = 13551615
            End With

            ' Less than 100% condition
            With .FormatConditions.Add(Type:=xlCellValue, Operator:=xlLess, Formula1:="=1")
                .SetFirstPriority
                .Font.Color = -16383844
                .Interior.Color = 13551615
            End With

            ' Equal to 100% condition
            With .FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=1")
                .SetFirstPriority
                .Font.Color = -16752384
                .Interior.Color = 13561798
            End With
        End With
    End With

    allocationsWs.Activate
End Sub


Sub CreateJournalEntry()
    ' Generates the journal entry using the data from the Allocations sheet
    ' NOTE: Running this will clear any existing journal entry

    Dim allocationsWs As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim endDataCol As String

    Dim wsJournalEntry As Worksheet
    Dim employee As String
    Dim payType As String
    Dim payValue As Double, allocatedPayValue As Double
    Dim grantName As String
    Dim journalEntryRow As Integer

    Set allocationsWs = Worksheets("Allocations")
    Set wsJournalEntry = Worksheets("Journal Entry")

    lastRow = allocationsWs.Cells(allocationsWs.Rows.Count, "A").End(xlUp).Row
    lastCol = allocationsWs.Cells(3, allocationsWs.Columns.Count).End(xlToLeft).Column
    endDataCol = Split(allocationsWs.Cells(1, lastCol - 1).Address, "$")(1)

    journalEntryRow = 2

    Dim data() As Variant
    ReDim data(1 To lastRow * lastCol, 1 To 7)

    Dim payrollCell As Range
    Dim grantCell As Range
    Dim index As Integer
    index = 1

    ' Populated the array with the journal entry data
    For Each payrollCell In allocationsWs.Range("C3:C" & lastRow)
        employee = allocationsWs.Cells(payrollCell.Row, 1).Value
        payType = allocationsWs.Cells(payrollCell.Row, 2).Value
        payValue = payrollCell.Value

        If payValue <> 0 Then
            For Each grantCell In allocationsWs.Range("D" & payrollCell.Row & ":" & endDataCol & payrollCell.Row)
                If grantCell.Value <> "0" Then
                    grantName = allocationsWs.Cells(2, grantCell.Column).Value
                    allocatedPayValue = Application.WorksheetFunction.Round(payValue * grantCell.Value, 2)

                    data(index, 1) = employee
                    data(index, 2) = payType
                    data(index, 3) = "=VLOOKUP(RC[-2],Employees!C[-5]:C[-3],3,FALSE)"
                    data(index, 4) = "=VLOOKUP(RC[-2],'Account Types'!C[-6]:C[-5],2,FALSE)"
                    data(index, 5) = allocatedPayValue
                    data(index, 7) = grantName
                    index = index + 1
                End If
            Next grantCell
        End If
    Next payrollCell

    ' Delete any existing journal entry data
    wsJournalEntry.Rows("2:" & wsJournalEntry.Rows.Count).Delete

    With wsJournalEntry.Columns("H")
        .NumberFormat = "0.00"
        .FormatConditions.Delete
        With .FormatConditions.Add(Type:=xlCellValue, Operator:=xlLess, Formula1:="=0")
            .Font.Color = RGB(255, 0, 0)
        End With
    End With

    ' Apply the journal entry data to the sheet
    wsJournalEntry.Range("D2:J" & index).Value = data
    AddSumIfFormulas

    wsJournalEntry.Activate
End Sub


Sub AddSumIfFormulas()
    Dim wsJournal As Worksheet
    Dim wsAccountTypes As Worksheet
    Dim wsPayrollSummary As Worksheet
    Dim lastRowJournal As Long
    Dim lastRowAccountTypes As Long

    Set wsJournalEntry = Worksheets("Journal Entry")
    Set wsAccountTypes = Worksheets("Account Types")
    Set wsPayrollSummary = Worksheets("Payroll_Summary")

    lastRowJournal = wsJournalEntry.Cells(wsJournalEntry.Rows.Count, "D").End(xlUp).Row
    lastRowAccountTypes = wsAccountTypes.Cells(wsAccountTypes.Rows.Count, "B").End(xlUp).Row

    Dim i As Long
    For i = 1 To lastRowAccountTypes
        wsJournalEntry.Cells(lastRowJournal + i, "G").Formula = "='Account Types'!B" & i
        wsJournalEntry.Cells(lastRowJournal + i, "H").Formula = "=SUMIF($G$2:$G$" & lastRowJournal & ", 'Account Types'!$B$" & i & ", $H$2:$H$" & lastRowJournal & ")*-1"
    Next i

    ' Get the payroll total from the Payroll_Summary worksheet
    Dim lastCol As Long, lastColName As String, lastRow As Long
    lastCol = wsPayrollSummary.Cells(1, wsPayrollSummary.Columns.Count).End(xlToLeft).Column
    lastColName = Split(wsPayrollSummary.Cells(1, lastCol).Address, "$")(1)
    lastRow = wsPayrollSummary.Cells(wsPayrollSummary.Rows.Count, lastCol).End(xlUp).Row

    wsJournalEntry.Cells(lastRowJournal + i + 2, "G").Value = "PAYROLL SUMMARY TOTAL"
    wsJournalEntry.Cells(lastRowJournal + i + 2, "H").Formula = "=Payroll_Summary!" & lastColName & lastRow

    wsJournalEntry.Cells(lastRowJournal + i + 3, "G").Value = "DIFF"
    wsJournalEntry.Cells(lastRowJournal + i + 3, "H").Formula = "=SUM(H" & lastRowJournal + 1 & ":H" & lastRowJournal + i + 2 & ")"
End Sub


Sub DeleteZeroRows()
    Dim wsJournalEntry As Worksheet
    Dim rngData As Range
    Dim i As Long

    Set wsJournalEntry = Worksheets("Journal Entry")
    Set rngData = wsJournalEntry.Range("H1", wsJournalEntry.Cells(wsJournalEntry.Rows.Count, "H").End(xlUp))

    For i = rngData.Rows.Count To 1 Step -1
        If rngData.Cells(i, 1).Value = 0 Then
            rngData.Cells(i, 1).EntireRow.Delete
        End If
    Next i
End Sub


Sub DragAndDrop()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim rng As Range
    Dim currentVal As Variant

    Set ws = Worksheets("Payroll_Summary")
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Set rng = ws.Range("B3:B" & lastRow)

    For i = 1 To rng.Rows.Count - 1
        If rng.Cells(i, 1) <> "" Then
            currentVal = rng.Cells(i, 1).Value
            Do While rng.Cells(i + 1, 1) = "" Or rng.Cells(i + 1, 1) = currentVal
                i = i + 1
                rng.Cells(i, 1).Value = currentVal
            Loop
        End If
    Next i
End Sub


Sub SumPayrollSummary()
    Dim ws As Worksheet
    Dim lastRow As Long

    Set ws = Worksheets("Payroll_Summary")
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    ' Copy column A from Employees to column N in Payroll_Summary
    ws.Range("N3:N" & lastRow).Value = Worksheets("Employees").Range("A3:A" & lastRow).Value

    ' Calculate sums for each employee using SumIf formula
    ws.Range("O3:O" & lastRow).Formula = "=SUMIF(B:B, N3, C:C)"
    ws.Range("P3:P" & lastRow).Formula = "=SUMIF(B:B, N3, E:E)"
    ws.Range("Q3:Q" & lastRow).Formula = "=SUMIF(B:B, N3, I:I)"

    ' Reformat column C to remove the text format
    With ws.Range("C:I")
        .NumberFormat = "0.00"
        .Value = .Value
    End With
    ' Rename column headers
    ws.Range("N2").Value = "Name"
    ws.Range("O2").Value = "Wages"
    ws.Range("P2").Value = "Payroll Taxes & Workers Comp"
    ws.Range("Q2").Value = "Medical & Retirement Services"
End Sub