Function sbTimeDiff(dtFrom As Date, dtTo As Date, _
vwh As Variant, _
Optional vHolidays As Variant, _
Optional vBreaks As Variant) As Date
'Returns time between dtFrom and dtTo but counts only
'dates and hours given in table vwh: for example
'09:00 17:00 'Monday
'09:00 17:00 'Tuesday
'09:00 17:00 'Wednesday
'09:00 17:00 'Thursday
'09:00 17:00 'Friday
'00:00 00:00 'Saturday
'00:00 00:00 'Sunday
'00:00 00:00 'Holidays
'This table defines hours to count for each day of the
'week (starting with Monday, 2 columns) and for holidays.
'Holidays given in vHolidays overrule week days.
'If you define a break table with break limits greater zero
'then the duration of each break exceeding the applicable
'time for this day will be subtracted from each day's time,
'but only down to the limit time, table needs to be sorted
'by limits in increasing order:
'Break table example
'Limit Duration (title row is not part of the table)
'6:00 0:30
'9:00 0:15
'
'http://sulprobil.com/Get_it_done/IT/Excel_Fun/Excel_VBA/sbTimeDiff/sbtimediff.html
'Reverse("moc.LiborPlus.www") (C) (P) Bernd Plumhoff 21-Mar-2020 PB V1.1
Dim dt2 As Date, dt3 As Date, dt4 As Date, dt5 As Date
Dim i As Long, lTo As Long, lFrom As Long
Dim lWDFrom As Long, lWDTo As Long, lWDi As Long
Dim objHolidays As Object, objBreaks As Object, v As Variant
sbTimeDiff = 0#
If dtTo <= dtFrom Then Exit Function
Set objHolidays = CreateObject("Scripting.Dictionary")
If Not IsMissing(vHolidays) Then
For Each v In vHolidays
objHolidays(v.Value) = 1
Next v
End If
If Not IsMissing(vBreaks) Then
Set objBreaks = CreateObject("Scripting.Dictionary")
For i = 1 To vBreaks.Rows.Count
objBreaks(CDate(vBreaks.Cells(i, 1))) = _
CDate(vBreaks.Cells(i, 2))
Next i
End If
lFrom = Int(dtFrom): lWDFrom = Weekday(lFrom, vbMonday)
lTo = Int(dtTo): lWDTo = Weekday(lTo, vbMonday)
If lFrom = lTo Then
lWDi = lWDTo: If objHolidays(lTo) Then lWDi = 8
dt3 = lTo + CDate(vwh(lWDi, 2))
If dt3 > dtTo Then dt3 = dtTo
dt2 = lTo + CDate(vwh(lWDi, 1))
If dt2 < dtFrom Then dt2 = dtFrom
If dt3 > dt2 Then
dt2 = dt3 - dt2
Else
dt2 = 0#
End If
If Not IsMissing(vBreaks) Then
dt2 = sbBreaks(dt2, objBreaks)
End If
sbTimeDiff = dt2
Set objHolidays = Nothing
Set objBreaks = Nothing
Exit Function
End If
lWDi = lWDFrom: If objHolidays(lFrom) Then lWDi = 8
If dtFrom - lFrom >= CDate(vwh(lWDi, 2)) Then
dt2 = 0#
Else
dt2 = lFrom + CDate(vwh(lWDi, 1))
If dt2 < dtFrom Then dt2 = dtFrom
dt2 = lFrom + CDate(vwh(lWDi, 2)) - dt2
If Not IsMissing(vBreaks) Then
dt2 = sbBreaks(dt2, objBreaks)
End If
End If
lWDi = lWDTo: If objHolidays(lTo) Then lWDi = 8
If dtTo - lTo <= CDate(vwh(lWDi, 1)) Then
dt4 = 0#
Else
dt4 = lTo + CDate(vwh(lWDi, 2))
If dt4 > dtTo Then dt4 = dtTo
dt4 = dt4 - lTo - CDate(vwh(lWDi, 1))
If Not IsMissing(vBreaks) Then
dt4 = sbBreaks(dt4, objBreaks)
End If
End If
dt3 = 0#
For i = lFrom + 1 To lTo - 1
lWDi = Weekday(i, vbMonday)
If objHolidays(i) Then lWDi = 8
dt5 = CDate(vwh(lWDi, 2)) - CDate(vwh(lWDi, 1))
If Not IsMissing(vBreaks) Then
dt5 = sbBreaks(dt5, objBreaks)
End If
dt3 = dt3 + dt5
Next i
Set objHolidays = Nothing
Set objBreaks = Nothing
sbTimeDiff = dt2 + dt3 + dt4
End Function
Private Function sbBreaks(ByVal dt As Date, objBreaks As Object) As Date
'Subtract break durations from dt as long as it exceeds the break limit,
'but not below break limit.
'Reverse("moc.LiborPlus.www") (C) (P) Bernd Plumhoff 22-Mar-2020 PB V0.992
Dim dtTemp As Date
Dim k As Long
k = 0
Do While k <= UBound(objBreaks.keys)
If dt > objBreaks.keys()(k) + objBreaks.items()(k) - dtTemp Then
dt = dt - objBreaks.items()(k)
dtTemp = dtTemp + objBreaks.items()(k)
ElseIf dt > objBreaks.keys()(k) - dtTemp Then
dt = objBreaks.keys()(k) - dtTemp
Exit Do
End If
k = k + 1
Loop
sbBreaks = dt
End Function
