Copy formulas down a summary page to individual time sheets

pbebow

New Member
Joined
Feb 15, 2021
Messages
15
Office Version
  1. 2013
Platform
  1. Windows
I keep track of payroll for my father in law's Care Workers, I have weekly time sheets set up for the whole year, then I have the summary page at the end (I've tried in the same workbook and a different workbook). The summary page references back to each weeks payroll to get the date and each person's weekly hours. I would like to be able to have each week automatically go to the correct worksheet without having to manually enter in everyone. I want to copy and paste it down the sheet and have it reference the correct worksheet, if that makes sense. Currently I type in =then click in the correct spot on the worksheet for that persons total hours and hit enter. But I have to do it for each employee every week and would prefer to have it automatically do it for me.

Screenshot payroll.png
 

Some videos you may like

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.

kanadaaa

Board Regular
Joined
Dec 29, 2019
Messages
186
Office Version
  1. 365
Platform
  1. Windows
First, rename the index number of the sheet "Payroll" to 0, as in the image below:

Capture.PNG


Make sure that your sheet name hasn't changed after editing.
If it changed, you edited a wrong property.
Then, try the code below in a standard module (make sure that you save or make a copy of the workbook before running the macro).

VBA Code:
Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error GoTo IsInArrayError: 'array is empty
        For Each element In arr
            If element = valToBeFound Then
                IsInArray = True
                Exit Function
            End If
        Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function

Function Cnv3LMonthToNum(cnvMonth As String) As String
    If cnvMonth = "Jan" Then
        Cnv3LMonthToNum = "01"
    ElseIf cnvMonth = "Feb" Then
        Cnv3LMonthToNum = "02"
    ElseIf cnvMonth = "Mar" Then
        Cnv3LMonthToNum = "03"
    ElseIf cnvMonth = "Apr" Then
        Cnv3LMonthToNum = "04"
    ElseIf cnvMonth = "May" Then
        Cnv3LMonthToNum = "05"
    ElseIf cnvMonth = "Jun" Then
        Cnv3LMonthToNum = "06"
    ElseIf cnvMonth = "Jul" Then
        Cnv3LMonthToNum = "07"
    ElseIf cnvMonth = "Aug" Then
        Cnv3LMonthToNum = "08"
    ElseIf cnvMonth = "Sep" Then
        Cnv3LMonthToNum = "09"
    ElseIf cnvMonth = "Oct" Then
        Cnv3LMonthToNum = "10"
    ElseIf cnvMonth = "Nov" Then
        Cnv3LMonthToNum = "11"
    ElseIf cnvMonth = "Dec" Then
        Cnv3LMonthToNum = "12"
    Else: Cnv3LMonthToNum = CVErr(xlErrNA)
    End If
End Function

Sub Payroll()
    'Get emplyees' names
    Dim pr As Worksheet, wsCnt As Long, namesRow As Long, namesCnt As Long, iLoop As Long, i As Long, employees() As String
    Set pr = Sheets("Payroll")
    wsCnt = ActiveWorkbook.Worksheets.Count - 1
    namesRow = Sheets(wsCnt).Range("H" & Rows.Count).End(xlUp).Row
    namesCnt = (namesRow - 1) / 10
    iLoop = 0
    For i = 0 To namesCnt - 1
        ReDim Preserve employees(i)
        employees(i) = Sheets(wsCnt).Range("A" & 2 + iLoop)
        'Debug.Print Sheets(wsCnt).Range("A" & 2 + iLoop).Address
        iLoop = iLoop + 10
    Next i
    '====Set employees()
    
    'Get weeks already on sheet "Payroll"
    Dim weeks() As String, fnd As Range, tempFnd As Range
    
    Set fnd = pr.Range("C:C").Find("*", pr.Range("C3"), xlValues)
    Set tempFnd = fnd
    i = 0
    Do While Not fnd Is Nothing
        ReDim Preserve weeks(i)
        If fnd <> "Week Ending" Then weeks(i) = fnd
        Set fnd = pr.Range("C:C").FindNext(fnd)
        If fnd.Address = tempFnd.Address Then
            Exit Do
        End If
        i = i + 1
    Loop
    '====Set weeks()
    
    'Get sheet names
    Dim shNames() As String, DBQ As String
    DBQ = """"
    For i = 0 To wsCnt - 1
        ReDim Preserve shNames(i)
        If Sheets(i + 1).Name <> "Payroll" Then
            shNames(i) = Sheets(i + 1).Name
            If Len(shNames(i)) = 8 Then
                shNames(i) = Cnv3LMonthToNum(Mid(shNames(i), 3, 3)) & "/" & "0" & Left(shNames(i), 1) & "/" & Right(shNames(i), 2)
            ElseIf Len(shNames(i)) = 9 Then
                shNames(i) = Cnv3LMonthToNum(Mid(shNames(i), 4, 3)) & "/" & Left(shNames(i), 2) & "/" & Right(shNames(i), 2)
            Else
                MsgBox "There are sheets that are not named in the form" & DBQ & "(d)d-Mmm-yy" & DBQ, vbExclamation, "Error"
                Exit Sub
            End If
        End If
    Next i
    '====Set shNames()
    
    'Get weeks not on sheet "Payroll"
    Dim nWeeks() As String, j As Long
    j = 0
    For i = LBound(shNames) To UBound(shNames)
        If IsInArray(shNames(i), weeks) = False Then
            ReDim Preserve nWeeks(j)
            nWeeks(j) = shNames(i)
            j = j + 1
        End If
    Next i
    '====Set nWeeks()
    
    'Output values into sheet "Payroll"
    Dim outputRow As Long, msg As Long, srcWs As Worksheet
    For i = LBound(nWeeks) To UBound(nWeeks)
        msg = MsgBox("Would you like to add data for the week ending:" & vbCrLf & vbCrLf & MonthName(Left(nWeeks(i), 2)) & " " _
            & Mid(nWeeks(i), 4, 2) & " 20" & Right(nWeeks(i), 2), vbYesNo, "Confirmation")
        If msg = vbYes Then
            Application.ScreenUpdating = False
            outputRow = pr.Range("A" & Rows.Count).End(xlUp).Row + 3
            pr.Range("C" & outputRow) = nWeeks(i)
            pr.Range("E" & outputRow) = "=SUM(D" & outputRow & ":" & "D" & outputRow + UBound(employees) & ")"
            pr.Range(Cells(outputRow, "A"), Cells(outputRow + UBound(employees), "E")).BorderAround Weight:=xlThin
            

            If Val(Mid(nWeeks(i), 4, 2)) >= 10 Then
                Set srcWs = Sheets(Mid(nWeeks(i), 4, 2) & "-" & Left(MonthName(Left(nWeeks(i), 2)), 3) & "-" & Right(nWeeks(i), 2))
            Else
                Set srcWs = Sheets(Mid(nWeeks(i), 5, 1) & "-" & Left(MonthName(Left(nWeeks(i), 2)), 3) & "-" & Right(nWeeks(i), 2))
            End If
            For j = 0 To UBound(employees)
                pr.Range("A" & outputRow + j) = employees(j)
                pr.Range("B" & outputRow + j) = srcWs.Range("H" & 10 * (j + 1) + 1) 'H11, H21, H31...
            Next j
            Application.ScreenUpdating = True
        End If
    Next i
    
End Sub
 

kanadaaa

Board Regular
Joined
Dec 29, 2019
Messages
186
Office Version
  1. 365
Platform
  1. Windows
Sorry, I found out that you don't need to renumber worksheets to get this macro to work.
Some updates:
The code in #2 didn't have a function to output wages to the sheet "Payroll", but you can get those values if you do the following:
First, make a sheet named "WagePerHour" like so:
Payroll.xlsm
ABCDEFG
1Wage/hEmployees
212Ashley
310MadisonJessieCindyRobinDarcyLowell
WagePerHour

Note that the worksheet to create needs to look identical with the image above.
Then, try the following code in a standard module:
VBA Code:
Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error GoTo IsInArrayError: 'array is empty
        For Each element In arr
            If element = valToBeFound Then
                IsInArray = True
                Exit Function
            End If
        Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function

Function Cnv3LMonthToNum(cnvMonth As String) As String
    If cnvMonth = "Jan" Then
        Cnv3LMonthToNum = "01"
    ElseIf cnvMonth = "Feb" Then
        Cnv3LMonthToNum = "02"
    ElseIf cnvMonth = "Mar" Then
        Cnv3LMonthToNum = "03"
    ElseIf cnvMonth = "Apr" Then
        Cnv3LMonthToNum = "04"
    ElseIf cnvMonth = "May" Then
        Cnv3LMonthToNum = "05"
    ElseIf cnvMonth = "Jun" Then
        Cnv3LMonthToNum = "06"
    ElseIf cnvMonth = "Jul" Then
        Cnv3LMonthToNum = "07"
    ElseIf cnvMonth = "Aug" Then
        Cnv3LMonthToNum = "08"
    ElseIf cnvMonth = "Sep" Then
        Cnv3LMonthToNum = "09"
    ElseIf cnvMonth = "Oct" Then
        Cnv3LMonthToNum = "10"
    ElseIf cnvMonth = "Nov" Then
        Cnv3LMonthToNum = "11"
    ElseIf cnvMonth = "Dec" Then
        Cnv3LMonthToNum = "12"
    Else: Cnv3LMonthToNum = CVErr(xlErrNA)
    End If
End Function

Sub Payroll()

    'Get emplyees' names
    Dim pr As Worksheet, wsCnt As Long, namesRow As Long, namesCnt As Long, iLoop As Long, i As Long, employees() As String, colors() As Long
   
    Set pr = Sheets("Payroll")
    wsCnt = ActiveWorkbook.Worksheets.Count - 2 'EDIT THIS NUMBER ACCORDING TO THE NUMBER OF SHEETS THAT START WITH AN ALPHABET
                                                                                'Now it's 2 because we have sheets named "Payroll" and "WagePerHour"
    namesRow = Sheets(wsCnt).Range("H" & Rows.Count).End(xlUp).Row
    namesCnt = (namesRow - 1) / 10
    iLoop = 0
    For i = 0 To namesCnt - 1
        ReDim Preserve employees(i)
        ReDim Preserve colors(i)
        employees(i) = Sheets(wsCnt).Range("A" & 2 + iLoop)
        colors(i) = Sheets(wsCnt).Range("A" & 2 + iLoop).Font.ColorIndex
        iLoop = iLoop + 10
    Next i
    '====Set employees()
   
    'Get weeks already on sheet "Payroll"
    Dim weeks() As String, fnd As Range, tempFnd As Range
   
    Set fnd = pr.Range("C:C").Find("*", pr.Range("C3"), xlValues)
    Set tempFnd = fnd
    i = 0
    Do While Not fnd Is Nothing
        ReDim Preserve weeks(i)
        If fnd <> "Week Ending" Then weeks(i) = fnd
        Set fnd = pr.Range("C:C").FindNext(fnd)
        If fnd.Address = tempFnd.Address Then
            Exit Do
        End If
        i = i + 1
    Loop
    '====Set weeks()
   
    'Get sheet names
    Dim shNames() As String, DBQ As String
   
    DBQ = """"
    For i = 0 To wsCnt - 1
        ReDim Preserve shNames(i)
        If Sheets(i + 1).Name <> "Payroll" Then
            shNames(i) = Sheets(i + 1).Name
            If Len(shNames(i)) = 8 Then
                shNames(i) = Cnv3LMonthToNum(Mid(shNames(i), 3, 3)) & "/" & "0" & Left(shNames(i), 1) & "/" & Right(shNames(i), 2)
            ElseIf Len(shNames(i)) = 9 Then
                shNames(i) = Cnv3LMonthToNum(Mid(shNames(i), 4, 3)) & "/" & Left(shNames(i), 2) & "/" & Right(shNames(i), 2)
            Else
                MsgBox "There are sheets that are not named in the form" & DBQ & "(d)d-Mmm-yy" & DBQ, vbExclamation, "Error"
                Exit Sub
            End If
        End If
    Next i
    '====Set shNames()
   
    'Get weeks not on sheet "Payroll"
    Dim nWeeks() As String, j As Long
   
    j = 0
    For i = LBound(shNames) To UBound(shNames)
        If IsInArray(shNames(i), weeks) = False Then
            ReDim Preserve nWeeks(j)
            nWeeks(j) = shNames(i)
            j = j + 1
        End If
    Next i
    '====Set nWeeks()
   
    'Output values into sheet "Payroll"
    Dim outputRow As Long, msg As Long, srcWs As Worksheet, fndWage As Range, wage As Single
   
    For i = LBound(nWeeks) To UBound(nWeeks)
        msg = MsgBox("Would you like to add data for the week ending:" & vbCrLf & vbCrLf & MonthName(Left(nWeeks(i), 2)) & " " _
            & Mid(nWeeks(i), 4, 2) & " 20" & Right(nWeeks(i), 2), vbYesNo, "Confirmation")
        If msg = vbYes Then
            Application.ScreenUpdating = False
            outputRow = pr.Range("A" & Rows.Count).End(xlUp).Row + 3
            If Val(Mid(nWeeks(i), 4, 2)) >= 10 Then
                Set srcWs = Sheets(Mid(nWeeks(i), 4, 2) & "-" & Left(MonthName(Left(nWeeks(i), 2)), 3) & "-" & Right(nWeeks(i), 2))
            Else
                Set srcWs = Sheets(Mid(nWeeks(i), 5, 1) & "-" & Left(MonthName(Left(nWeeks(i), 2)), 3) & "-" & Right(nWeeks(i), 2))
            End If
            For j = LBound(employees) To UBound(employees)
                Set fndWage = Sheets("WagePerHour").Range("2:3").Find(employees(j), , xlValues, xlWhole, xlByRows)
                If fndWage Is Nothing Then
                    MsgBox "Wage per hour for the following employee is not specified:" & vbCrLf & vbCrLf & employees(j), vbExclamation, "Error"
                    Exit Sub
                Else
                    wage = Sheets("WagePerHour").Range("A" & fndWage.Row)
                    pr.Range("A" & outputRow + j) = employees(j)
                    pr.Range("A" & outputRow + j).Font.ColorIndex = colors(j)
                    pr.Range("B" & outputRow + j) = srcWs.Range("H" & 10 * (j + 1) + 1) 'H11, H21, H31...
                    pr.Range("D" & outputRow + j) = "$" & Val(pr.Range("B" & outputRow + j)) * wage
                End If
            Next j
            pr.Range("C" & outputRow) = nWeeks(i)
            pr.Range("E" & outputRow) = "=SUM(D" & outputRow & ":" & "D" & outputRow + UBound(employees) & ")"
            pr.Range(Cells(outputRow, "A"), Cells(outputRow + UBound(employees), "E")).BorderAround Weight:=xlThin
            Application.ScreenUpdating = True
        End If
    Next i
   
End Sub
Result (bordered parts are filled automatically by the macro):
Capture1.PNG
 

kanadaaa

Board Regular
Joined
Dec 29, 2019
Messages
186
Office Version
  1. 365
Platform
  1. Windows
A workaround for an error that shows up if there's no data available for the sheet Payroll:
VBA Code:
Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error GoTo IsInArrayError: 'array is empty
        For Each element In arr
            If element = valToBeFound Then
                IsInArray = True
                Exit Function
            End If
        Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function

Function Cnv3LMonthToNum(cnvMonth As String) As String
    If cnvMonth = "Jan" Then
        Cnv3LMonthToNum = "01"
    ElseIf cnvMonth = "Feb" Then
        Cnv3LMonthToNum = "02"
    ElseIf cnvMonth = "Mar" Then
        Cnv3LMonthToNum = "03"
    ElseIf cnvMonth = "Apr" Then
        Cnv3LMonthToNum = "04"
    ElseIf cnvMonth = "May" Then
        Cnv3LMonthToNum = "05"
    ElseIf cnvMonth = "Jun" Then
        Cnv3LMonthToNum = "06"
    ElseIf cnvMonth = "Jul" Then
        Cnv3LMonthToNum = "07"
    ElseIf cnvMonth = "Aug" Then
        Cnv3LMonthToNum = "08"
    ElseIf cnvMonth = "Sep" Then
        Cnv3LMonthToNum = "09"
    ElseIf cnvMonth = "Oct" Then
        Cnv3LMonthToNum = "10"
    ElseIf cnvMonth = "Nov" Then
        Cnv3LMonthToNum = "11"
    ElseIf cnvMonth = "Dec" Then
        Cnv3LMonthToNum = "12"
    Else: Cnv3LMonthToNum = CVErr(xlErrNA)
    End If
End Function

Function IsArrayEmpty(arr As Variant) As Boolean
    On Error Resume Next
    IsArrayEmpty = True
    IsArrayEmpty = UBound(arr) < LBound(arr)
End Function

Sub Payroll()

    'Get emplyees' names
    Dim pr As Worksheet, wsCnt As Long, namesRow As Long, namesCnt As Long, iLoop As Long, i As Long, employees() As String, colors() As Long
   
    Set pr = Sheets("Payroll")
    wsCnt = ActiveWorkbook.Worksheets.Count - 2 'EDIT THIS NUMBER ACCORDING TO THE NUMBER OF SHEETS THAT START WITH AN ALPHABET
                                                                                'Now it's 2 because we have sheets named "Payroll" and "WagePerHour"
    namesRow = Sheets(wsCnt).Range("H" & Rows.Count).End(xlUp).Row
    namesCnt = (namesRow - 1) / 10
    iLoop = 0
    For i = 0 To namesCnt - 1
        ReDim Preserve employees(i)
        ReDim Preserve colors(i)
        employees(i) = Sheets(wsCnt).Range("A" & 2 + iLoop)
        colors(i) = Sheets(wsCnt).Range("A" & 2 + iLoop).Font.ColorIndex
        iLoop = iLoop + 10
    Next i
    '====Set employees()
   
    'Get weeks already on sheet "Payroll"
    Dim weeks() As String, fnd As Range, tempFnd As Range
   
    Set fnd = pr.Range("C:C").Find("*", pr.Range("C3"), xlValues)
    Set tempFnd = fnd
    i = 0
    Do While Not fnd Is Nothing
        ReDim Preserve weeks(i)
        If fnd <> "Week Ending" Then weeks(i) = fnd
        Set fnd = pr.Range("C:C").FindNext(fnd)
        If fnd.Address = tempFnd.Address Then
            Exit Do
        End If
        i = i + 1
    Loop
    '====Set weeks()
   
    'Get sheet names
    Dim shNames() As String, DBQ As String
   
    DBQ = """"
    For i = 0 To wsCnt - 1
        ReDim Preserve shNames(i)
        If Sheets(i + 1).Name <> "Payroll" Then
            shNames(i) = Sheets(i + 1).Name
            If Len(shNames(i)) = 8 Then
                shNames(i) = Cnv3LMonthToNum(Mid(shNames(i), 3, 3)) & "/" & "0" & Left(shNames(i), 1) & "/" & Right(shNames(i), 2)
            ElseIf Len(shNames(i)) = 9 Then
                shNames(i) = Cnv3LMonthToNum(Mid(shNames(i), 4, 3)) & "/" & Left(shNames(i), 2) & "/" & Right(shNames(i), 2)
            Else
                MsgBox "There are sheets that are not named in the form" & DBQ & "(d)d-Mmm-yy" & DBQ, vbExclamation, "Error"
                Exit Sub
            End If
        End If
    Next i
    '====Set shNames()
   
    'Get weeks not on sheet "Payroll"
    Dim nWeeks() As String, j As Long
   
    j = 0
    For i = LBound(shNames) To UBound(shNames)
        If IsInArray(shNames(i), weeks) = False Then
            ReDim Preserve nWeeks(j)
            nWeeks(j) = shNames(i)
            j = j + 1
        End If
    Next i
    '====Set nWeeks()
   
    If IsArrayEmpty(nWeeks) = True Then 'Show error message if there's no data to output to Payroll
        MsgBox "The sheet " & DBQ & "Payroll" & DBQ & " already has all the data available.", vbExclamation, "Error"
        Exit Sub
    End If
     
    'Output values into sheet "Payroll"
    Dim outputRow As Long, msg As Long, srcWs As Worksheet, fndWage As Range, wage As Single
       
    For i = LBound(nWeeks) To UBound(nWeeks)
        msg = MsgBox("Would you like to add data for the week ending:" & vbCrLf & vbCrLf & MonthName(Left(nWeeks(i), 2)) & " " _
            & Mid(nWeeks(i), 4, 2) & " 20" & Right(nWeeks(i), 2), vbYesNo, "Confirmation")
        If msg = vbYes Then
            Application.ScreenUpdating = False
            outputRow = pr.Range("A" & Rows.Count).End(xlUp).Row + 3
            If Val(Mid(nWeeks(i), 4, 2)) >= 10 Then
                Set srcWs = Sheets(Mid(nWeeks(i), 4, 2) & "-" & Left(MonthName(Left(nWeeks(i), 2)), 3) & "-" & Right(nWeeks(i), 2))
            Else
                Set srcWs = Sheets(Mid(nWeeks(i), 5, 1) & "-" & Left(MonthName(Left(nWeeks(i), 2)), 3) & "-" & Right(nWeeks(i), 2))
            End If
            For j = LBound(employees) To UBound(employees)
                Set fndWage = Sheets("WagePerHour").Range("2:3").Find(employees(j), , xlValues, xlWhole, xlByRows)
                If fndWage Is Nothing Then
                    MsgBox "Wage per hour for the following employee is not specified:" & vbCrLf & vbCrLf & employees(j), vbExclamation, "Error"
                    Exit Sub
                Else
                    wage = Sheets("WagePerHour").Range("A" & fndWage.Row)
                    pr.Range("A" & outputRow + j) = employees(j)
                    pr.Range("A" & outputRow + j).Font.ColorIndex = colors(j)
                    pr.Range("B" & outputRow + j) = srcWs.Range("H" & 10 * (j + 1) + 1) 'H11, H21, H31...
                    pr.Range("D" & outputRow + j) = "$" & Val(pr.Range("B" & outputRow + j)) * wage
                End If
            Next j
            pr.Range("C" & outputRow) = nWeeks(i)
            pr.Range("E" & outputRow) = "=SUM(D" & outputRow & ":" & "D" & outputRow + UBound(employees) & ")"
            pr.Range(Cells(outputRow, "A"), Cells(outputRow + UBound(employees), "E")).BorderAround Weight:=xlThin
            Application.ScreenUpdating = True
        End If
    Next i
   
End Sub
 

pbebow

New Member
Joined
Feb 15, 2021
Messages
15
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Sorry, I found out that you don't need to renumber worksheets to get this macro to work.
Some updates:
The code in #2 didn't have a function to output wages to the sheet "Payroll", but you can get those values if you do the following:
First, make a sheet named "WagePerHour" like so:
Payroll.xlsm
ABCDEFG
1Wage/hEmployees
212Ashley
310MadisonJessieCindyRobinDarcyLowell
WagePerHour

Note that the worksheet to create needs to look identical with the image above.
Then, try the following code in a standard module:
VBA Code:
Function IsInArray(valToBeFound As Variant, arr As Variant) As Boolean
    Dim element As Variant
    On Error GoTo IsInArrayError: 'array is empty
        For Each element In arr
            If element = valToBeFound Then
                IsInArray = True
                Exit Function
            End If
        Next element
Exit Function
IsInArrayError:
On Error GoTo 0
IsInArray = False
End Function

Function Cnv3LMonthToNum(cnvMonth As String) As String
    If cnvMonth = "Jan" Then
        Cnv3LMonthToNum = "01"
    ElseIf cnvMonth = "Feb" Then
        Cnv3LMonthToNum = "02"
    ElseIf cnvMonth = "Mar" Then
        Cnv3LMonthToNum = "03"
    ElseIf cnvMonth = "Apr" Then
        Cnv3LMonthToNum = "04"
    ElseIf cnvMonth = "May" Then
        Cnv3LMonthToNum = "05"
    ElseIf cnvMonth = "Jun" Then
        Cnv3LMonthToNum = "06"
    ElseIf cnvMonth = "Jul" Then
        Cnv3LMonthToNum = "07"
    ElseIf cnvMonth = "Aug" Then
        Cnv3LMonthToNum = "08"
    ElseIf cnvMonth = "Sep" Then
        Cnv3LMonthToNum = "09"
    ElseIf cnvMonth = "Oct" Then
        Cnv3LMonthToNum = "10"
    ElseIf cnvMonth = "Nov" Then
        Cnv3LMonthToNum = "11"
    ElseIf cnvMonth = "Dec" Then
        Cnv3LMonthToNum = "12"
    Else: Cnv3LMonthToNum = CVErr(xlErrNA)
    End If
End Function

Sub Payroll()

    'Get emplyees' names
    Dim pr As Worksheet, wsCnt As Long, namesRow As Long, namesCnt As Long, iLoop As Long, i As Long, employees() As String, colors() As Long
  
    Set pr = Sheets("Payroll")
    wsCnt = ActiveWorkbook.Worksheets.Count - 2 'EDIT THIS NUMBER ACCORDING TO THE NUMBER OF SHEETS THAT START WITH AN ALPHABET
                                                                                'Now it's 2 because we have sheets named "Payroll" and "WagePerHour"
    namesRow = Sheets(wsCnt).Range("H" & Rows.Count).End(xlUp).Row
    namesCnt = (namesRow - 1) / 10
    iLoop = 0
    For i = 0 To namesCnt - 1
        ReDim Preserve employees(i)
        ReDim Preserve colors(i)
        employees(i) = Sheets(wsCnt).Range("A" & 2 + iLoop)
        colors(i) = Sheets(wsCnt).Range("A" & 2 + iLoop).Font.ColorIndex
        iLoop = iLoop + 10
    Next i
    '====Set employees()
  
    'Get weeks already on sheet "Payroll"
    Dim weeks() As String, fnd As Range, tempFnd As Range
  
    Set fnd = pr.Range("C:C").Find("*", pr.Range("C3"), xlValues)
    Set tempFnd = fnd
    i = 0
    Do While Not fnd Is Nothing
        ReDim Preserve weeks(i)
        If fnd <> "Week Ending" Then weeks(i) = fnd
        Set fnd = pr.Range("C:C").FindNext(fnd)
        If fnd.Address = tempFnd.Address Then
            Exit Do
        End If
        i = i + 1
    Loop
    '====Set weeks()
  
    'Get sheet names
    Dim shNames() As String, DBQ As String
  
    DBQ = """"
    For i = 0 To wsCnt - 1
        ReDim Preserve shNames(i)
        If Sheets(i + 1).Name <> "Payroll" Then
            shNames(i) = Sheets(i + 1).Name
            If Len(shNames(i)) = 8 Then
                shNames(i) = Cnv3LMonthToNum(Mid(shNames(i), 3, 3)) & "/" & "0" & Left(shNames(i), 1) & "/" & Right(shNames(i), 2)
            ElseIf Len(shNames(i)) = 9 Then
                shNames(i) = Cnv3LMonthToNum(Mid(shNames(i), 4, 3)) & "/" & Left(shNames(i), 2) & "/" & Right(shNames(i), 2)
            Else
                MsgBox "There are sheets that are not named in the form" & DBQ & "(d)d-Mmm-yy" & DBQ, vbExclamation, "Error"
                Exit Sub
            End If
        End If
    Next i
    '====Set shNames()
  
    'Get weeks not on sheet "Payroll"
    Dim nWeeks() As String, j As Long
  
    j = 0
    For i = LBound(shNames) To UBound(shNames)
        If IsInArray(shNames(i), weeks) = False Then
            ReDim Preserve nWeeks(j)
            nWeeks(j) = shNames(i)
            j = j + 1
        End If
    Next i
    '====Set nWeeks()
  
    'Output values into sheet "Payroll"
    Dim outputRow As Long, msg As Long, srcWs As Worksheet, fndWage As Range, wage As Single
  
    For i = LBound(nWeeks) To UBound(nWeeks)
        msg = MsgBox("Would you like to add data for the week ending:" & vbCrLf & vbCrLf & MonthName(Left(nWeeks(i), 2)) & " " _
            & Mid(nWeeks(i), 4, 2) & " 20" & Right(nWeeks(i), 2), vbYesNo, "Confirmation")
        If msg = vbYes Then
            Application.ScreenUpdating = False
            outputRow = pr.Range("A" & Rows.Count).End(xlUp).Row + 3
            If Val(Mid(nWeeks(i), 4, 2)) >= 10 Then
                Set srcWs = Sheets(Mid(nWeeks(i), 4, 2) & "-" & Left(MonthName(Left(nWeeks(i), 2)), 3) & "-" & Right(nWeeks(i), 2))
            Else
                Set srcWs = Sheets(Mid(nWeeks(i), 5, 1) & "-" & Left(MonthName(Left(nWeeks(i), 2)), 3) & "-" & Right(nWeeks(i), 2))
            End If
            For j = LBound(employees) To UBound(employees)
                Set fndWage = Sheets("WagePerHour").Range("2:3").Find(employees(j), , xlValues, xlWhole, xlByRows)
                If fndWage Is Nothing Then
                    MsgBox "Wage per hour for the following employee is not specified:" & vbCrLf & vbCrLf & employees(j), vbExclamation, "Error"
                    Exit Sub
                Else
                    wage = Sheets("WagePerHour").Range("A" & fndWage.Row)
                    pr.Range("A" & outputRow + j) = employees(j)
                    pr.Range("A" & outputRow + j).Font.ColorIndex = colors(j)
                    pr.Range("B" & outputRow + j) = srcWs.Range("H" & 10 * (j + 1) + 1) 'H11, H21, H31...
                    pr.Range("D" & outputRow + j) = "$" & Val(pr.Range("B" & outputRow + j)) * wage
                End If
            Next j
            pr.Range("C" & outputRow) = nWeeks(i)
            pr.Range("E" & outputRow) = "=SUM(D" & outputRow & ":" & "D" & outputRow + UBound(employees) & ")"
            pr.Range(Cells(outputRow, "A"), Cells(outputRow + UBound(employees), "E")).BorderAround Weight:=xlThin
            Application.ScreenUpdating = True
        End If
    Next i
  
End Sub
Result (bordered parts are filled automatically by the macro):
View attachment 32203
Hmmm, wow, thank you so much for taking the time to answer and try to help but that is definitely way over my head. Guess I'll just have to go through and input each one separately, I though there would be a simpler solution. Thanks again
 

kanadaaa

Board Regular
Joined
Dec 29, 2019
Messages
186
Office Version
  1. 365
Platform
  1. Windows
Hmmm, wow, thank you so much for taking the time to answer and try to help but that is definitely way over my head. Guess I'll just have to go through and input each one separately, I though there would be a simpler solution. Thanks again
Why? It’s simple: make a new sheet, copy&paste the code, run the macro. Done. Nothing complicated.
You really shouldn’t give up here because it’ll be much easier to deal with all those payroll values.
To be honest, I don’t want you to throw this away without even trying it.
 

pbebow

New Member
Joined
Feb 15, 2021
Messages
15
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Why? It’s simple: make a new sheet, copy&paste the code, run the macro. Done. Nothing complicated.
You really shouldn’t give up here because it’ll be much easier to deal with all those payroll values.
To be honest, I don’t want you to throw this away without even trying it.
OK So I just open a new worksheet in the same workbook. copy and paste the macro and it's good?
 

kanadaaa

Board Regular
Joined
Dec 29, 2019
Messages
186
Office Version
  1. 365
Platform
  1. Windows
OK So I just open a new worksheet in the same workbook. copy and paste the macro and it's good?
Yep.

1. Create a new sheet and rename it as WagePerHour
2. Arrange cell contents just as in the image in #3
3. If your current workbook isn’t a macro-enabled workbook, save it as an .xlsm file
4. If you don’t have the developer tab in the ribbon, turn it on (see Developer Tab in Excel)
5. Open the code tab and insert a module
6. Copy and Paste the code into the module
7. Press macros on the developer tab and run the macro

Let me know if any error occurs.
 

pbebow

New Member
Joined
Feb 15, 2021
Messages
15
Office Version
  1. 2013
Platform
  1. Windows
OK So I just open a new worksheet in the same workbook. copy and paste the macro and it's good?
Why? It’s simple: make a new sheet, copy&paste the code, run the macro. Done. Nothing complicated.
You really shouldn’t give up here because it’ll be much easier to deal with all those payroll values.
To be honest, I don’t want you to throw this away without even trying it.
OK I really want this to work, but I really have no experiences with macros at all. I'm assuming you still want me to add another worksheet called WagePerHour, which I have done and made it look like yours. But where do I copy and paste the code and how do I get it to work? I tried googling it and did the Alt F11 for the VBA and tried what they said but it didn't work. If you could put it in simpleton steps for me that would be great. Would it help if I uploaded the mini sheet? My workbook has 52 weeks worth of sheets that are labeled the week ending date (1-Jan-21 through 31-Dec-21) and then the "Payroll" sheet that is where I need the magic to happen and then I added the sheet you told me "WagePerHour".... Thank you!
 

pbebow

New Member
Joined
Feb 15, 2021
Messages
15
Office Version
  1. 2013
Platform
  1. Windows
Yep.

1. Create a new sheet and rename it as WagePerHour
2. Arrange cell contents just as in the image in #3
3. If your current workbook isn’t a macro-enabled workbook, save it as an .xlsm file
4. If you don’t have the developer tab in the ribbon, turn it on (see Developer Tab in Excel)
5. Open the code tab and insert a module
6. Copy and Paste the code into the module
7. Press macros on the developer tab and run the macro

Let me know if any error occurs.
Sorry, you answered while I was asking again.... This worked!!! Yay!!!! Thank you so much!!!! This is awesome!!!
 

Watch MrExcel Video

Forum statistics

Threads
1,122,961
Messages
5,599,061
Members
414,281
Latest member
Engjamal2021

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top