1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
|
Function WorkingHrs(StartAt As Date, EndAt As Date, Optional WorkStart As Date = #9:00:00 AM#, _
Optional WorkEnd As Date = #5:00:00 PM#, Optional Workdays As String = "23456", _
Optional Holidays As Variant, Optional Breaks As Variant)
' 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!
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
Dim BreaksArr() As Date
Dim DayLength As Date
Dim WorkParts(1 To 4) As Long
' 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
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
Next
End If
' populate Breaks array
If Not IsMissing(Breaks) Then
ReDim BreaksArr(0) As Date
For Each x In Breaks
If UBound(BreaksArr) = 0 Then
ReDim BreaksArr(1 To 1) As Date
BreaksArr(1) = x
Else
ReDim Preserve BreaksArr(1 To UBound(BreaksArr) + 1)
BreaksArr(UBound(BreaksArr)) = x
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
DayStart = WorkStart
DayEnd = WorkEnd
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
If Not IsMissing(Breaks) Then
For x = 1 To UBound(BreaksArr) - (UBound(BreaksArr) Mod 2) Step 2
' Break outside working time
If BreaksArr(x + 1) < DayStart Or BreaksArr(x) > DayEnd Then
'do nothing
' Break covers all of working time
ElseIf BreaksArr(x) < DayStart And BreaksArr(x + 1) > DayEnd Then
WorkingHrs = WorkingHrs - (DayEnd - DayStart)
' Break fits inside working time
ElseIf DayStart <= BreaksArr(x) And DayEnd >= BreaksArr(x + 1) Then
WorkingHrs = WorkingHrs - (BreaksArr(x + 1) - BreaksArr(x))
' Break starts before working time but does not extend beyond it
ElseIf BreaksArr(x) < DayStart Then
WorkingHrs = WorkingHrs - (BreaksArr(x + 1) - DayStart)
' Break starts within working time but extends beyond it
Else
WorkingHrs = WorkingHrs - (DayEnd - BreaksArr(x))
End If
Next
End If
End If
Next
DayLength = WorkEnd - WorkStart
If Not IsMissing(Breaks) Then
For x = 1 To UBound(BreaksArr) - (UBound(BreaksArr) Mod 2) Step 2
' Break outside working time
If BreaksArr(x + 1) < WorkStart Or BreaksArr(x) > WorkEnd Then
'do nothing
' Break covers all of working time
ElseIf BreaksArr(x) < WorkStart And BreaksArr(x + 1) > WorkEnd Then
DayLength = DayLength - (WorkEnd - WorkStart)
' Break fits inside working time
ElseIf WorkStart <= BreaksArr(x) And WorkEnd >= BreaksArr(x + 1) Then
DayLength = DayLength - (BreaksArr(x + 1) - BreaksArr(x))
' Break starts before working time but does not extend beyond it
ElseIf BreaksArr(x) < WorkStart Then
DayLength = DayLength - (BreaksArr(x + 1) - WorkStart)
' Break starts within working time but extends beyond it
Else
DayLength = DayLength - (WorkEnd - BreaksArr(x))
End If
Next
End If
' convert days to hours
'WorkingHrs = WorkingHrs * 24
Debug.Print Format(WorkingHrs, "[h]:mm:ss")
WorkParts(1) = Int(CDbl(WorkingHrs) / CDbl(DayLength))
WorkingHrs = WorkingHrs - WorkParts(1) * DayLength
WorkParts(2) = Hour(WorkingHrs)
WorkingHrs = WorkingHrs - TimeSerial(WorkParts(2), 0, 0)
WorkParts(3) = Minute(WorkingHrs)
WorkingHrs = WorkingHrs - TimeSerial(0, WorkParts(3), 0)
WorkParts(4) = Second(WorkingHrs)
WorkingHrs = ""
If WorkParts(1) = 1 Then
WorkingHrs = "1 day"
ElseIf WorkParts(1) > 1 Then
WorkingHrs = WorkParts(1) & " days"
End If
If WorkingHrs <> "" And WorkParts(2) > 0 Then WorkingHrs = WorkingHrs & " "
If WorkParts(2) = 1 Then
WorkingHrs = WorkingHrs & "1 hour"
ElseIf WorkParts(2) > 1 Then
WorkingHrs = WorkingHrs & WorkParts(2) & " hours"
End If
If WorkingHrs <> "" And WorkParts(3) > 0 Then WorkingHrs = WorkingHrs & " "
If WorkParts(3) = 1 Then
WorkingHrs = WorkingHrs & "1 minute"
ElseIf WorkParts(3) > 1 Then
WorkingHrs = WorkingHrs & WorkParts(3) & " minutes"
End If
If WorkingHrs <> "" And WorkParts(4) > 0 Then WorkingHrs = WorkingHrs & " "
If WorkParts(4) = 1 Then
WorkingHrs = WorkingHrs & "1 second"
ElseIf WorkParts(4) > 1 Then
WorkingHrs = WorkingHrs & WorkParts(4) & " seconds"
End If
Cleanup:
On Error GoTo 0
Set Dict = Nothing
End Function
|
