VERY trick one!

[Mark Sreeves]

I need a datediff function that takes office hours into account.

my office hours are
08:00 to 16:30 Monday to Thursday
with half an hour lunch 12:00 to 12:30

08:00 to 13:00 on Fridays (no lunch break)


The help desk people have a system of recording faults.

a Fault can be raised 24 hours per day

and Closed usually within office hours

are you still following this?

statisics need to be maintained on how long the fault was open for. A simple datediff will calclate this but we also want to take offce hours into account.


at the moment, if a fault is reported 14:00 on a Friday and closed 09:00 on Monday it is logged as 67 hours. We want this to be changed to 1 hour if you see what I mean.

[Paul282]

What an excellent question!!!

I'm gonna have a crack at this, back to you soon

(They don't give me much to do here!)

[r0ach]

It sounds to me like you are only taking office hours into account. My I am misunderstanding. All the hours for the weekend was not taken into account.

Can't you just get the datediff (backwards ) from when the fault was closed, to the start of the office hours?

Unless off course the fault was only closed at 09:00 Tuesday morning. Then you will have to subtract the hours between 16:30 monday and 08:00 Tuesday.

But, I'm not sure if you want only office hours.

[Chris]

Damn good question & back to you with an faster solution...

[Chris]

Hi Mark Sreeves, here is my solution,

Option Explicit
Public Sub Main()
Dim SDT$
Dim EDT$
Dim FT(1) As String
Dim TFHr As Double 'Total fault time 0Seconds)
Dim TOFHr As Double 'Total off office time (seconds)
Dim TROFHr As Double 'Total rebat Off Office time (Seconds)
Dim xCnt%

SDT = "09/06/2000 14:00:00"
EDT = "12/06/2000 09:00:00"
'Note:
'The Off Office Hour Betweem each day is:
'Sun - Mon = 16Hr
'Mon - Tue = 16Hr
'Tue - Wed = 16Hr
'Wed - Thu = 16Hr
'Thu - Fri = 19Hr
'Fri - Sat = 24Hr
'Sat - Sun = 24Hr
'All the calculation is base on Second.

'Step 1
'Calculate the total fault time
TFHr = DateDiff("s", SDT, EDT)

'Step 2
'Calculate the Total Off Office Hour.
FT(0) = DateValue(SDT)
FT(1) = DateValue(EDT)
TOFHr = 0
While FT(0) <= FT(1)
    Select Case Weekday(FT(0))
    Case 1, 7 'Sun & Sat
        TOFHr = TOFHr + 24
    Case 2, 3, 4, 5 'Mon, Tue, Wed & Thu
        TOFHr = TOFHr + 16
    Case 6 'Fri
        TOFHr = TOFHr + 19
    End Select
    FT(0) = DateValue(DateValue(FT(0)) + 1)
Wend
'Convert into seconds
TOFHr = TOFHr * 3600

'Restore the original value
FT(0) = SDT
FT(1) = EDT

'Step 3
'Calculate the Rebat Off Office time
TROFHr = 0
For xCnt = 0 To 1
    Select Case Weekday(FT(xCnt))
    Case 1, 7 'Sun & Sat
        TROFHr = TROFHr + 24
    Case 2, 3, 4, 5 'Mon, Tue, Wed & Thu
        If TimeValue(FT(xCnt)) < TimeValue("8:00:00") Then
            TROFHr = TROFHr + Abs(DateDiff("s", FT(xCnt), Mid(FT(xCnt), 1, 10) & " 8:00:00"))
        ElseIf (TimeValue(FT(xCnt)) >= TimeValue("8:00:00")) And (TimeValue(FT(xCnt)) <= TimeValue("16:30:00")) Then
            TROFHr = TROFHr + 28800
        ElseIf TimeValue(FT(xCnt)) > TimeValue("13:00:00") Then
            TROFHr = TROFHr + 28800 + Abs(DateDiff("s", FT(xCnt), Mid(FT(xCnt), 1, 10) & " 16:30:00"))
        End If
    Case 6 'Fri
        If TimeValue(FT(xCnt)) < TimeValue("8:00:00") Then
            TROFHr = TROFHr + Abs(DateDiff("s", FT(xCnt), Mid(FT(xCnt), 1, 10) & " 8:00:00"))
        ElseIf (TimeValue(FT(xCnt)) >= TimeValue("8:00:00")) And (TimeValue(FT(xCnt)) <= TimeValue("13:00:00")) Then
            TROFHr = TROFHr + 28800
        ElseIf TimeValue(FT(xCnt)) > TimeValue("13:00:00") Then
            TROFHr = TROFHr + 28800 + Abs(DateDiff("s", FT(xCnt), Mid(FT(xCnt), 1, 10) & " 13:00:00"))
        End If
    End Select
Next

'Step 4
'Recalculate the Total fault time
TFHr = Abs(TFHr - (TOFHr - TROFHr))

'Step 5
'Conversion
Debug.Print "Total Fault time is " & Format(TFHr \ 3600, "00") & ":" & Format(((TFHr - ((TFHr \ 3600) * 3600)) \ 60), "00") & ":" & Format(TFHr Mod 60, "00")

End Sub

[Edited by Chris on 06-09-2000 at 10:59 PM]

[Paul Warren]

i haven't spent the last two hours on this for nothing so I might as well share it.

Private Sub Form_Load()

Dim intTotal As Integer
Dim intDays As Integer
Dim intCount As Integer
Dim intHours(1 To 7) As Integer
Dim strStart As String
Dim strEnd As String

' Setup the number of hours per day
intHours(Monday) = 8
intHours(Tuesday) = 8
intHours(Wednesday) = 8
intHours(Thursday) = 8
intHours(Friday) = 5
intHours(Saturday) = 0
intHours(Sunday) = 0

' Some dummy dates for testing
strStart = "12/6/00 13:00"
strEnd = "19/6/00 09:00"

' find out how many days there are between
intDays = DateDiff("D", strStart, strEnd)

' Calculate the number of hours on the start date
intTotal = START_HOUR + intHours(WeekDay(CDate(strStart), vbMonday)) - Hour(CDate(strStart))

' if the call is logged after office hours then
' set the total to 0
If (intTotal < 0) Then
    intTotal = 0
' if the call is logged before office hours then
' set the total to max hours for that day
ElseIf (intTotal > intHours(WeekDay(CDate(strStart), vbMonday))) Then
    intTotal = intHours(intHours(WeekDay(CDate(strStart), vbMonday)))
End If

' If there are no days between then we have our answer
If intDays = 0 Then
    txtDifference = intTotal
    Exit Sub
End If

' If there's more than one day then go though totalling the hours
If intDays > 1 Then
    For intCount = 1 To intDays - 1
        intTotal = intTotal + intHours(WeekDay(DateAdd("D", intCount, CDate(strStart)), vbMonday))
    Next
End If

' Calculate the number of hours on the last day
intTotal = intTotal + (Hour(CDate(strEnd)) - START_HOUR)

MsgBox intTotal & " Hours", , "Total"

End Sub

[Mark Sreeves]

First of al , ithe thread should have said:
Very Tricky One

I missed of the Y

anyway,
I did some "black-box" testing on both lots of code and,

this is thye output from Chris's:

Start Time: 12/06/2000 07:00:00
End Time: 12/06/2000 09:00:00
Total Fault time is 05:00:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Start Time: 12/06/2000 08:00:00
End Time: 12/06/2000 09:00:00
Total Fault time is 01:00:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Start Time: 12/06/2000 06:00:00
End Time: 12/06/2000 09:00:00
Total Fault time is 03:00:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Hmm... not quite right

and Paul Warren

Start Time: 12/06/2000 08:00:00
End Time: 13/06/2000 10:00:00
10 Hours Total
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Start Time: 12/06/2000 09:00:00
End Time: 13/06/2000 10:00:00
9 Hours Total
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Start Time: 12/06/2000 06:00:00
End Time: 13/06/2000 10:00:00
12 Hours Total <- ought to be 10 still
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

this one isn't right either!

Anyway, Thanks for your contributions I've neally cracked it using my own method now but you keep trying if you want!

[Chris]

Hi! Mark Sreeves, I just found out, I've made a mistake in my Step 3 calculation and I've amended and redo the test and the result just show below:

Public Sub Main()
Dim SDT$
Dim EDT$
Dim FT(1) As String
Dim TFHr As Double 'Total fault time 0Seconds)
Dim TOFHr As Double 'Total off office time (seconds)
Dim TROFHr As Double 'Total rebat Off Office time (Seconds)
Dim xCnt%

'Start Time: 12/06/2000 07:00:00
'End Time: 12/06/2000 09:00:00
SDT = "12/06/2000 06:00:00"
EDT = "13/06/2000 10:00:00"

'Note:
'The Off Office Hour Betweem each day is:
'Sun - Mon = 16Hr
'Mon - Tue = 16Hr
'Tue - Wed = 16Hr
'Wed - Thu = 16Hr
'Thu - Fri = 19Hr
'Fri - Sat = 24Hr
'Sat - Sun = 24Hr
'All the calculation is base on Second.

'Step 1
'Calculate the total fault time
TFHr = DateDiff("s", SDT, EDT)

'Step 2
'Calculate the Total Off Office Hour.
FT(0) = DateValue(SDT)
FT(1) = DateValue(EDT)
TOFHr = 0
While FT(0) <= FT(1)
    Select Case Weekday(FT(0))
    Case 1, 7 'Sun & Sat
        TOFHr = TOFHr + 24
    Case 2, 3, 4, 5 'Mon, Tue, Wed & Thu
        TOFHr = TOFHr + 16
    Case 6 'Fri
        TOFHr = TOFHr + 19
    End Select
    FT(0) = DateValue(DateValue(FT(0)) + 1)
Wend
'Convert into seconds
TOFHr = TOFHr * 3600

'Restore the original value
FT(0) = SDT
FT(1) = EDT

'Step 3
'Calculate the Rebat Off Office time
TROFHr = 0
For xCnt = 0 To 1
    Select Case Weekday(FT(xCnt))
    Case 1, 7 'Sun & Sat
        TROFHr = TROFHr + 24
    Case 2, 3, 4, 5 'Mon, Tue, Wed & Thu
        If TimeValue(FT(xCnt)) < TimeValue("8:00:00") Then
            TROFHr = TROFHr + (28800 - Abs(DateDiff("s", FT(xCnt), Mid(FT(xCnt), 1, 10) & " 8:00:00")))
        ElseIf (TimeValue(FT(xCnt)) >= TimeValue("8:00:00")) And (TimeValue(FT(xCnt)) <= TimeValue("16:30:00")) Then
            TROFHr = TROFHr + 28800
        ElseIf TimeValue(FT(xCnt)) > TimeValue("13:00:00") Then
            TROFHr = TROFHr + 28800 + Abs(DateDiff("s", FT(xCnt), Mid(FT(xCnt), 1, 10) & " 16:30:00"))
        End If
    Case 6 'Fri
        If TimeValue(FT(xCnt)) < TimeValue("8:00:00") Then
            TROFHr = TROFHr + (28800 - Abs(DateDiff("s", FT(xCnt), Mid(FT(xCnt), 1, 10) & " 8:00:00")))
        ElseIf (TimeValue(FT(xCnt)) >= TimeValue("8:00:00")) And (TimeValue(FT(xCnt)) <= TimeValue("13:00:00")) Then
            TROFHr = TROFHr + 28800
        ElseIf TimeValue(FT(xCnt)) > TimeValue("13:00:00") Then
            TROFHr = TROFHr + 28800 + Abs(DateDiff("s", FT(xCnt), Mid(FT(xCnt), 1, 10) & " 13:00:00"))
        End If
    End Select
Next

'Step 4
'Recalculate the Total fault time
TFHr = Abs(TFHr - (TOFHr - TROFHr))

'Step 5
'Conversion
Debug.Print "Start Time: " & SDT
Debug.Print "End Time  : " & EDT
Debug.Print "Total Fault time is " & Format(TFHr \ 3600, "00") & ":" & Format(((TFHr - ((TFHr \ 3600) * 3600)) \ 60), "00") & ":" & Format(TFHr Mod 60, "00")
Debug.Print "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
End Sub

Results
Start Time: 09/06/2000 14:00:00
End Time : 12/06/2000 09:00:00
Total Fault time is 01:00:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Start Time: 12/06/2000 07:00:00
End Time : 12/06/2000 09:00:00
Total Fault time is 01:00:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Start Time: 12/06/2000 08:00:00
End Time : 12/06/2000 09:00:00
Total Fault time is 01:00:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Start Time: 12/06/2000 06:00:00
End Time : 12/06/2000 09:00:00
Total Fault time is 01:00:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Start Time: 12/06/2000 08:00:00
End Time : 13/06/2000 10:00:00
Total Fault time is 10:00:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Start Time: 12/06/2000 09:00:00
End Time : 13/06/2000 10:00:00
Total Fault time is 09:00:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Start Time: 12/06/2000 06:00:00
End Time : 13/06/2000 10:00:00
Total Fault time is 10:00:00
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

[Paul Warren]

When I run my code and put in the dates you've used it works fine and gives the result of 10 hours for the last one. What on earth is that all about ?

[Paul Warren]

I've tweked it a bit for easier testing so give it a go and let me know if it doesn't work. I would be very interested to know if you still get the 12 hour result :

Option Explicit

Dim intHours(1 To 7) As Integer
Private Const START_HOUR As Integer = 8

Public Sub Main()

Dim strStart As String
Dim strEnd As String
Dim intCount As Integer

' Setup the number of hours per day
intHours(1) = 8 ' Monday
intHours(2) = 8 ' Tuesday
intHours(3) = 8 ' etc...
intHours(4) = 8
intHours(5) = 5
intHours(6) = 0 ' Saturday
intHours(7) = 0 ' Sunday

For intCount = 1 To 5

    strStart = InputBox("Enter start :", "Start", "12/06/2000 06:00:00")
    strEnd = InputBox("Enter end :", "End", "13/06/2000 10:00:00")
    
    Calc_Hours strStart, strEnd

Next intCount

End Sub

Private Sub Calc_Hours(strStart As String, strEnd As String)

Dim intTotal As Integer
Dim intDays As Integer
Dim intCount As Integer
Dim txtDifference As String

' Find out how many days there are between
intDays = DateDiff("D", strStart, strEnd)

' Calculate the number of hours on the start date
intTotal = START_HOUR + intHours(WeekDay(CDate(strStart), vbMonday)) - Hour(CDate(strStart))

' if the call is logged after office hours then
' set the total to 0
If (intTotal < 0) Then
    intTotal = 0
' if the call is logged before office hours then
' set the total to max hours for that day
ElseIf (intTotal > intHours(WeekDay(CDate(strStart), vbMonday))) Then
    intTotal = intHours(WeekDay(CDate(strStart), vbMonday))
End If

' If there are no days between then we have our answer
If intDays = 0 Then
    txtDifference = intTotal
    Exit Sub
End If

' If there's more than one day then go though totalling the hours
If intDays > 1 Then
    For intCount = 1 To intDays - 1
        intTotal = intTotal + intHours(WeekDay(DateAdd("D", intCount, CDate(strStart)), vbMonday))
    Next
End If

' Calculate the number of hours on the last day
intTotal = intTotal + (Hour(CDate(strEnd)) - START_HOUR)

MsgBox intTotal & " Hours", , "Total"

End Sub

[Mark Sreeves]

I've completed my own version now!

I'll have a look at both your versions a bit later because I've got to work on somthing urgent now!

My own version very pretty complicated but totally configurable.

it expresses the "raw" time and days as an array of bytes.

So to set a lunch-break I just have to clear a BIT.

I then do a bitwise AND on raw time with each day an then count the set bits.

So far each day is an array of 6 bytes which gives the times to the closest half hour. I'll probably expand upon this to give the closest quarter of an hour because that will be close enough for what I need.