I am a supporter of
St. Joseph's hospice.
 If you find this site useful or if it helped you, consider a small donation to
St. Joseph's, please.

Information on
St. Joseph's

JustGiving - Sponsor me now!

 

sbTimeDiff

"Patriotism is supporting your country all the time, and your government when it deserves it." [Mark Twain]

Name

sbTimeDiff() - Calculate time between two time points but count only time as specified for week days and for holidays subtracted by break times if working time exceeds specified time

Synopsis

sbTimeDiff(dtFrom, dtTo, vwh [, vHolidays] [, vBreaks])

Description

Calculate time between two time points but count only time as specified for week days and for holidays subtracted by break times if given for specified working time.

Options

dtFrom
      Datetime to count from

dtTo
     
Datetime to count to

vwh
      8 by 2 matrix defining start time and end time for each weekday and for holidays, first row for Mondays, 8th row for holidays

vHolidays
      Optional. List of holidays (integer datetime)

vBreaks
      Optional. N x 2 matrix specifying working time (sorted in ascending order) and break time to subtract if corresponding time for a day has been worked

Example

sbTimeDiff_Example1

Option Explicit

Enum mc_Macro_Categories
    mcFinancial = 1
    mcDate_and_Time
    mcMath_and_Trig
    mcStatistical
    mcLookup_and_Reference
    mcDatabase
    mcText
    mcLogical
    mcInformation
    mcCommands
    mcCustomizing
    mcMacro_Control
    mcDDE_External
    mcUser_Defined
    mcFirst_custom_category
    mcSecond_custom_category 'and so on
End Enum 'mc_Macro_Categories

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 the longest break which is smaller
'than the applicable time for this day will be subtracted
'from each day's time, table needs to be sorted by limits
'in increasing order:
'Break table example
'Limit Duration (title row is not part of the table)
'4:00  0:15
'8:00  0:30
'
‘http://sulprobil.com/Get_it_done/IT/Excel_Fun/Excel_VBA/sbTimeDiff/sbtimediff.html
'Reverse("moc.LiborPlus.www") 31-Mar-2019 PB V1.0
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

Function sbBreaks(dt As Date, objBreaks As Object) As Date
'Find longest break <= dt
'Reverse("moc.LiborPlus.www") 10-Feb-2019 PB V0.982
Dim k As Long
k = 0
If dt >= objBreaks.keys()(k) Then
    Do While k < UBound(objBreaks.keys)
        'Break table needs to be sorted in increasing order
        If dt >= objBreaks.keys()(k + 1) Then
            k = k + 1
        Else
            Exit Do
        End If
    Loop
    If dt > objBreaks.items()(k) Then
        dt = dt - objBreaks.items()(k)
    Else
        sbBreaks = CVErr(xlErrValue)
        Exit Function
    End If
End If
sbBreaks = dt
End Function

Sub DescribeFunction_sbTimeDiff()

'Run this only once, then you will see this description in the function menu

Dim FuncName As String
Dim FuncDesc As String
Dim Category As String
Dim ArgDesc(1 To 5) As String

FuncName = "sbTimeDiff"
FuncDesc = "Returns time between dtFrom and dtTo but counts only " & _
            "time given in table vwh. Holidays given in vHolidays " & _
            "overrule week days, breaks given in vBreaks are subtracted" & _
            "if corresponding time has been worked"
Category = mcDate_and_Time
ArgDesc(1) = "Start date and time where to count from"
ArgDesc(2) = "End date and time to count to"
ArgDesc(3) = "Range or array which defines which time to count during the week starting from Monday, " & _
            "8 by 2 matrix defining start time and end time for each weekday (8th row for holidays)"
ArgDesc(4) = "Optional list of holidays which overrule week days, define time to count in 8th row of vwh"
ArgDesc(5) = "Optional. N x 2 matrix specifying working time (sorted in ascending order) and " & _
             "break time to subtract if corresponding time for a day has been worked"

Application.MacroOptions _
    Macro:=FuncName, _
    Description:=FuncDesc, _
    Category:=Category, _
    ArgumentDescriptions:=ArgDesc

End Sub

Sulprobil   Get it done   Contact   Disclaimer   Impressum   Download