Calculate Daily and Weekly Overtime from Table - vba

Question

I'm trying to set up an Excel (2010) spreadsheet to calculate overtime for employees from a spreadsheet generated by the time clock. The report from the time clock gives total hours only. Overtime can be calculated by separating hours into regular hours and OT hours. Anything over 10 hours in a day counts as OT hours. Once you have hit 40 REGULAR hours (not including OT), all hours past that point are counted as OT. Then all OT is added up. If you never hit 40 regular hours, but still have daily OT, then daily OT is used.
I feel like this shouldn't be too terribly difficult. I've tried using some conditional formulas to calculate and break out the OT, but haven't been able to come up with anything that works in all cases and allows the process to be automated. I've included a link below to an example spreadsheet generated by the time clock. Is it possible to break out the OT the way I want without using VBA?
Example Spreadsheet
Please let me know if you need any additional information. At least some ideas of where to start would be very welcome, or if there are other posts that address similar matters I could use to get going (I haven't been able to find any that quite work in this situation). Thanks!

Answer 1

I needed a little brain challenge this morning so I decided to help you out. This is how I solved your problem.
Turn on developer
tab
Open the Visual Basic Editor ALT+F11 or
Insert a one standard Module
Copy and Paste the below code into that Module
Option Explicit
Sub OTHours()
Sheets(2).Activate
Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row).ClearContents
Dim c As Collection
Set c = New Collection
Dim e As Collection
Set e = New Collection
On Error GoTo RowHandler
Dim i As Long, r As Range
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("C" & i)
c.Add r.Row, r.Offset(0, -2) & "£" & r
Next i
For i = 1 To c.Count
If i <> c.Count Then
Dim j As Long
j = c.Item(i)
Dim m As Merged
Set m = New Merged
m.Name = Range("A" & c.Item(i))
m.Dates = Range("C" & c.Item(i))
Do Until j = c.Item(i + 1)
m.Hours = m.Hours + Range("F" & j)
m.Row = j
j = j + 1
Loop
Else
Dim k As Long
k = c.Item(i)
Set m = New Merged
m.Name = Range("A" & c.Item(i))
m.Dates = Range("C" & c.Item(i))
Do Until IsEmpty(Range("A" & k))
m.Hours = m.Hours + Range("F" & k)
m.Row = k
k = k + 1
Loop
End If
e.Add m
Next i
For i = 1 To e.Count
'Debug.Print e.Item(i).Name, e.Item(i).Dates, e.Item(i).Hours, e.Item(i).Row
Range("G" & e.Item(i).Row) = IIf(e.Item(i).Hours - 10 > 0, e.Item(i).Hours - 10, vbNullString)
Next i
PrintOvertime e
Exit Sub
RowHandler:
Resume Next
End Sub
Private Sub PrintOvertime(e As Collection)
Application.DisplayAlerts = False
Dim ws As Worksheet
For Each ws In Sheets
If StrComp(ws.Name, "Overtime Only", vbTextCompare) = 0 Then ws.Delete
Next
Application.DisplayAlerts = True
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Overtime Only"
Set ws = Sheets("Overtime Only")
With ws
Dim i As Long
.Range("A1") = "Applicant Name"
.Range("B1") = "Date"
.Range("C1") = "OT hours"
.Range("D1") = "Week Number"
For i = 1 To e.Count
If (e.Item(i).Hours - 10 > 0) Then
.Range("A" & .Range("A" & Rows.Count).End(xlUp).Row + 1) = e.Item(i).Name
.Range("B" & .Range("B" & Rows.Count).End(xlUp).Row + 1) = e.Item(i).Dates
.Range("C" & .Range("C" & Rows.Count).End(xlUp).Row + 1) = e.Item(i).Hours - 10
End If
Next i
.Columns.AutoFit
End With
PrintWeekNum
End Sub
Private Sub PrintWeekNum()
Dim ws As Worksheet
Set ws = Sheets("Overtime Only")
With ws
Dim i As Long
For i = 2 To .Range("C" & Rows.Count).End(xlUp).Row
Dim r As String
r = .Range("B" & i).Text
.Range("D" & i) = WorksheetFunction.WeekNum(Right(r, 4) & "-" & Left(r, 2) & "-" & Right(Left(r, 5), 2))
Next i
End With
End Sub
Now insert a Class Module
Copy and Paste the below code to it
Option Explicit
Public Name As String
Public Dates As Date
Public Hours As Double
Public Row As Long
Rename your Class Module to Merged
Note: you need to turn on the Properties Window, either click View on the menu bar then select Properties Window or hit F4
Select the Class Module and rename it from Class1 to Merged
Go back to the spreadsheet view and select Time Detail Sheet
Hit ALT+F8
or
select Macros on the Developer tab and hit Run
The OVERTIME results will be filled in to your Time Details Sheet column G
Also
There will be a new sheet added named Overtime Only which will have a table of all people who did extra hours. (and only people who earned Overtime)
The results will look like
Time Detail
Overtime Only

Answer 2

I took the answer from #mehow and modified it a bit to take weekly overtime into account. I'm not sure if it's the cleanest or most efficient way to go about it, but it gets the job done.
I created an additional class module, "DlyHrs," which holds hrs for a single day for a single employee. Each person has a collection of these DlyHrs objects, so their total regular and OT hours for the week can be tracked.
Class Module "DlyHrs" -
Option Explicit
Public Day As Date
Public totHrs As Double
Public regHrs As Double
Public otHrs As Double
Public row As Long
I modified the Class Module "Merged" as so -
Option Explicit
Public Name As String
Public Hrs As Collection
Public regHrs As Double
Public otHrs As Double
Public totHrs As Double
So far, it seems to be working, and breaking out all daily and weekly overtime correctly. Here is the entire code for the macro -
Option Explicit
Sub OTHours()
ThisWorkbook.Sheets("Time Detail").Activate
Range("T2:T" & Range("T" & Rows.Count).End(xlUp).row).ClearContents
Range("T1") = "OT"
Dim c As Collection
Set c = New Collection
Dim e As Collection
Set e = New Collection
On Error GoTo RowHandler
Dim i As Long, r As Range
For i = 2 To Range("A" & Rows.Count).End(xlUp).row
Set r = Range("H" & i)
c.Add r.row, r.Offset(0, -7) & "£" & r
Next i
'store name of previous person to know when to add new person to collection
Dim prev As String
prev = vbNullString
For i = 1 To c.Count
Dim j As Long
j = c.Item(i)
Dim curr As String
curr = Range("A" & j)
'if not dealing with a new person, add hours to existing person
'rather than creating new person
If curr = prev Then GoTo CurrentPerson
Dim m As Merged
Set m = New Merged
m.Name = Range("A" & c.Item(i))
Set m.Hrs = New Collection
CurrentPerson:
Dim curHrs As DlyHrs
Set curHrs = New DlyHrs
curHrs.Day = Range("H" & c.Item(i))
If i <> c.Count Then
'Add up hours column
Do Until j = c.Item(i + 1)
curHrs.totHrs = curHrs.totHrs + Range("K" & j)
curHrs.row = j
j = j + 1
Loop
Else
Do Until IsEmpty(Range("A" & j))
curHrs.totHrs = curHrs.totHrs + Range("K" & j)
curHrs.row = j
j = j + 1
Loop
End If
'break out regular and OT hours and add to current person
If m.regHrs = 40 Then 'all hrs to OT
curHrs.otHrs = curHrs.totHrs
m.totHrs = m.totHrs + curHrs.totHrs
m.otHrs = m.otHrs + curHrs.totHrs
ElseIf m.regHrs + curHrs.totHrs > 40 Then 'approaching 40
curHrs.regHrs = 40 - m.regHrs
curHrs.otHrs = curHrs.totHrs - curHrs.regHrs
m.totHrs = m.totHrs + curHrs.totHrs
m.regHrs = m.regHrs + curHrs.regHrs
m.otHrs = m.otHrs + curHrs.otHrs
ElseIf curHrs.totHrs > 10 Then 'not approaching 40, but daily ot
curHrs.otHrs = curHrs.totHrs - 10
curHrs.regHrs = curHrs.totHrs - curHrs.otHrs
m.totHrs = m.totHrs + curHrs.totHrs
m.regHrs = m.regHrs + curHrs.regHrs
m.otHrs = m.otHrs + curHrs.otHrs
Else 'no daily or weekly ot
m.totHrs = m.totHrs + curHrs.totHrs
m.regHrs = m.regHrs + curHrs.totHrs
End If
If curHrs.otHrs <> 0 Then
Range("T" & curHrs.row) = curHrs.otHrs
End If
m.Hrs.Add curHrs
Dim nextPerson As String
nextPerson = Range("A" & j)
'check if next name is a new person. if so, add current person to collection
If curr <> nextPerson Then
e.Add m
End If
prev = curr
Next i
Exit Sub
RowHandler:
Resume Next
End Sub