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.
-
If you would like to post, please check out the MrExcel Message Board FAQ and register here. If you forgot your password, you can reset your password.
Copy formulas down a summary page to individual time sheets
- Thread starter pbebow
- Start date
kanadaaa
Active Member
- Joined
- Dec 29, 2019
- Messages
- 348
- Office Version
- 365
- Platform
- Windows
First, rename the index number of the sheet "Payroll" to 0, as in the image below:
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).
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
Upvote
0
kanadaaa
Active Member
- Joined
- Dec 29, 2019
- Messages
- 348
- Office Version
- 365
- Platform
- 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:
Note that the worksheet to create needs to look identical with the image above.
Then, try the following code in a standard module:
Result (bordered parts are filled automatically by the macro):
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 | |||||||||
|---|---|---|---|---|---|---|---|---|---|
| A | B | C | D | E | F | G | |||
| 1 | Wage/h | Employees | |||||||
| 2 | 12 | Ashley | |||||||
| 3 | 10 | Madison | Jessie | Cindy | Robin | Darcy | Lowell | ||
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
Upvote
0
kanadaaa
Active Member
- Joined
- Dec 29, 2019
- Messages
- 348
- Office Version
- 365
- Platform
- 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
Upvote
0
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
Upvote
0
kanadaaa
Active Member
- Joined
- Dec 29, 2019
- Messages
- 348
- Office Version
- 365
- Platform
- Windows
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.
Upvote
0
OK So I just open a new worksheet in the same workbook. copy and paste the macro and it's good?
Upvote
0
kanadaaa
Active Member
- Joined
- Dec 29, 2019
- Messages
- 348
- Office Version
- 365
- Platform
- 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.
Upvote
0
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!
Upvote
0
Sorry, you answered while I was asking again.... This worked!!! Yay!!!! Thank you so much!!!! This is awesome!!!
Upvote
0
Similar threads
- Solved
