Function WorkingHrs(StartAt As Date, EndAt As Date, WorkStart As Date, WorkEnd As Date, Workdays As String, _
ParamArray Holidays())
' Function calculates working hours available within a specified datetime range, allowing for
' scheduled working hours, non-working days, and holidays (if desired)
' Workdays specifies days employees normally work. For example, to use Mon - Fri, use 23456.
' To do just Tue & Thu, use 35; etc.
' Assumes scheduled working hrs are the same on each working day!
' To use this function to calculate "working days", then simply divide the result from the function by
' the length of a standard workday in hours.
Dim Counter As Long
Dim Dict As Object
Dim x As Variant
Dim y As Variant
Dim Days(1 To 7) As Boolean
Dim WorkThisDay As Boolean
Dim HolThisDay As Boolean
Dim DateToday As Date
Dim DayStart As Date
Dim DayEnd As Date
' array indicates whether that weekday is a regular workday. Initialize to False
Days(1) = False
Days(2) = False
Days(3) = False
Days(4) = False
Days(5) = False
Days(6) = False
Days(7) = False
' populate array with results from Workdays argument
For Counter = 1 To Len(Workdays)
Days(Val(Mid(Workdays, Counter, 1))) = True
Next
On Error GoTo Cleanup
' populate holiday array
If Not IsMissing(Holidays) Then
Set Dict = CreateObject("Scripting.Dictionary")
For Each x In Holidays
' Each element of Holidays may itself be an array (or an Excel range with >1 cell). Test for that,
' and iterate through the elements of *that* array if needed. If not, then simply process the
' current element
If IsArray(x) Then
For Each y In x
If Not Dict.Exists(Format(y, "m/d/yyyy")) Then Dict.Add Format(y, "m/d/yyyy"), Format(y, "m/d/yyyy")
Next
Else
If Not Dict.Exists(Format(x, "m/d/yyyy")) Then Dict.Add Format(x, "m/d/yyyy"), Format(x, "m/d/yyyy")
End If
Next
End If
'loop through days in datetime range
For Counter = Int(StartAt) To Int(EndAt)
DateToday = CDate(Counter)
' determine if regular workday
WorkThisDay = Days(Weekday(DateToday, vbSunday))
' determine if holiday
If IsMissing(Holidays) Then
HolThisDay = False
Else
If Dict.Exists(Format(DateToday, "m/d/yyyy")) Then HolThisDay = True Else HolThisDay = False
End If
' if regular workday and not a holiday, figure out hrs from that day
If WorkThisDay And Not HolThisDay Then
' starts and ends on same day
If Int(StartAt) = Int(EndAt) Then
DayStart = IIf(CDate(StartAt - Int(StartAt)) > WorkStart, CDate(StartAt - Int(StartAt)), WorkStart)
DayEnd = IIf(CDate(EndAt - Int(EndAt)) < WorkEnd, CDate(EndAt - Int(EndAt)), WorkEnd)
WorkingHrs = IIf(CDbl(DayEnd - DayStart) < 0, 0, CDbl(DayEnd - DayStart))
' first day, if first day <> last day
ElseIf Counter = Int(StartAt) Then
DayStart = IIf(CDate(StartAt - Int(StartAt)) > WorkStart, CDate(StartAt - Int(StartAt)), WorkStart)
DayEnd = WorkEnd
WorkingHrs = IIf(CDbl(DayEnd - DayStart) < 0, 0, CDbl(DayEnd - DayStart))
' days in between start and end, if any
ElseIf Counter > Int(StartAt) And Counter < Int(EndAt) Then
WorkingHrs = WorkingHrs + CDbl(WorkEnd - WorkStart)
' last day, if first day <> last day
ElseIf Counter = Int(EndAt) Then
DayStart = IIf(CDate(EndAt - Int(EndAt)) > WorkStart, WorkStart, CDate(EndAt - Int(EndAt)))
DayEnd = IIf(CDate(EndAt - Int(EndAt)) < WorkEnd, CDate(EndAt - Int(EndAt)), WorkEnd)
WorkingHrs = WorkingHrs + IIf(CDbl(DayEnd - DayStart) < 0, 0, CDbl(DayEnd - DayStart))
End If
End If
Next
' convert days to hours
WorkingHrs = WorkingHrs * 24
Cleanup:
On Error GoTo 0
Set Dict = Nothing
End Function
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
After updating data my Excel graphs are showing too many dates | 8 | 32 | |
Copy all Sheet1-Sheets into a newly created workbook using VBA | 8 | 33 | |
sql server query from excel | 3 | 57 | |
Mac Excel column treating text as date | 2 | 31 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
15 Experts available now in Live!