Elapsed time hrs mins secs

**dasousa** · 05-11-2015, 02:12 AM

Reference https://www.accessforums.net/program...96/index2.html

Originally Posted by ssanfu

Here are the changes you requested.... returns hrs and mins (ie 29hrs 36mins)

Note the function name change.....

Code:

Public Function WorkingHrsMins(StartDate As Date, EndDate As Date) As String
'....................................................................
' Name:  WorkingHrsMins
' Inputs:   StartDate As Date & time
'              EndDate As Date & time
' Returns: String- number of hours & minutes not inclusive of weekends
' Author: Arvin Meyer
' Date:  February 19, 1997
'   Modified by Steve S (ssanfu)
'   Date: April 11, 2012
' Comment: Accepts two dates and returns the number
' of work hours and minutes between 8am and 8pm
' Note that this function does not account for holidays.
'....................................................................
    On Error GoTo Err_WorkingHrs

    Dim intCountDays As Integer
    Dim intHours As Integer
    Dim intMinutes As Integer
    Dim intTotalMin As Integer
    Dim dtStart As Date
    Dim dtEnd As Date
    Dim dtTemp As Date
    Dim tmStart As Date
    Dim tmEnd As Date

    intMinutes = 0
    intHours = 0
    intCountDays = 0
    intTotalMin = 0

    'check end date > start date
    If EndDate < StartDate Then
        dtTemp = StartDate
        StartDate = EndDate
        EndDate = dtTemp
    End If

    'get just the date portion
    dtStart = Int(StartDate)
    dtEnd = Int(EndDate)
    'get just the time portion
    tmStart = StartDate - dtStart
    tmEnd = EndDate - dtEnd

    'skip the first day
    dtStart = dtStart + 1

    Do While dtStart < dtEnd
        'Make the above < and not <= to not count the EndDate

        Select Case Weekday(dtStart)
            Case Is = 1, 7
                'do nothing
            Case Is = 2, 3, 4, 5, 6
                intCountDays = intCountDays + 1
        End Select
        dtStart = dtStart + 1
    Loop
    intTotalMin = intCountDays * 720

    'first day minutes
    intTotalMin = intTotalMin + DateDiff("n", tmStart, #8:00:00 PM#)
    'Last day minutes
    intTotalMin = intTotalMin + DateDiff("n", #8:00:00 AM#, tmEnd)

    intHours = intTotalMin \ 60   'hours
    intMinutes = intTotalMin Mod 60   'minutes

    'return value
    WorkingHrsMins = intHours & "hrs  " & intMinutes & "min"

Exit_WorkingHrs:
    Exit Function

Err_WorkingHrs:
    Select Case Err

        Case Else
            MsgBox Err.Description
            Resume Exit_WorkingHrs
    End Select

End Function

ssanfu,

Is it possibly to modify the code in order the response have the total of hours with the format hh:mm:ss ( exemple 30:10:13)

many tanks

**June7** · 05-11-2015, 10:37 AM

If you want elapsed time down to the seconds then the DateDiff must calc total seconds, not minutes.

Also:

intTotalSec = intCountDays * 720 * 60

Adjust code as needed.

Review https://www.accessforums.net/access/...ime-38266.html

**dasousa** · 05-11-2015, 11:18 AM

June7

Tank for your reply

I have try to change the code, but it returne the same response…
I’m new in this, can you help me change the ssanfu function WorkingHrsMins in order the response have the total of hours with the format hh:mm:ss

Tanks

**June7** · 05-11-2015, 01:00 PM

Post your attempted revised code. Let's see what you are not understanding about adapting code.

**dasousa** · 05-11-2015, 01:17 PM

-------------------

June7

I’m trying the below code, but since I’m novice I think that have incorrect update function , the response result is “0:0:0”

I’m trying a Starting sate: 30-04-2015 13:14:23 finish date: 30-04-2015 13:17:59 and the result should be : 0:03:36

Thank for your help

------------------------------------
Public Function WorkingHrsMins(StartDate As Date, EndDate As Date) As String
'................................................. ...................
' Name: WorkingHrs
' Inputs: StartDate As Date & time
' EndDate As Date & time
' Returns: Integer - number of hours not inclusive of weekends
' Author: Arvin Meyer
' Date: February 19, 1997
' Modified by Steve S (ssanfu)
' Date: April 11, 2012
' Comment: Accepts two dates and returns the number
' of work hours and minutes between 8am and 8pm
' Note that this function does not account for holidays.
'................................................. ...................
On Error GoTo Err_WorkingHrs
Const cBeginingTime As Date = #8:00:00 AM#
Const cEndingTime As Date = #8:00:00 PM#
Dim intCountDays As Integer
Dim intHours As Integer
Dim intMinutes As Integer
Dim intTotalMin As Integer
Dim intTotalSec As Integer
Dim dtStart As Date
Dim dtEnd As Date
Dim dtTemp As Date
Dim tmStart As Date
Dim tmEnd As Date
intMinutes = 0
intHours = 0
IntSeconds = 0
intCountDays = 0
intTotalMin = 0
WorkingHrsMins = 0
'check end date > start date
If EndDate < StartDate Then
dtTemp = StartDate
StartDate = EndDate
EndDate = dtTemp
End If
'get just the date portion
dtStart = Int(StartDate)
dtEnd = Int(EndDate)
'get just the time portion
tmStart = StartDate - dtStart
tmEnd = EndDate - dtEnd
'check start and end times are valid
If Not (tmStart >= cBeginingTime And tmStart <= cEndingTime) Then
MsgBox "Invalid start time. Start time before " & cBeginingTime
Exit Function
ElseIf Not (tmEnd >= cBeginingTime And tmEnd <= cEndingTime) Then
MsgBox "Invalid end time. End time after " & cEndingTime
Exit Function
End If
If dtStart = dtEnd Then
intTotalSec = DateDiff("s", tmStart, tmEnd)
Else
'skip the first day
dtStart = dtStart + 1
Do While dtStart < dtEnd
'Make the above < and not <= to not count the EndDate
Select Case Weekday(dtStart)
Case Is = 1, 7
'do nothing
Case Is = 2, 3, 4, 5, 6
intCountDays = intCountDays + 1
End Select
dtStart = dtStart + 1
Loop
intTotalSec = intCountDays * 720 * 60 'first day minutes
intTotalMin = intTotalMin + DateDiff("n", tmStart, cEndingTime) 'Last day minutes
intTotalMin = intTotalMin + DateDiff("n", cBeginingTime, tmEnd)

End If
intHours = intTotalMin \ 60 'hours
intMinutes = intTotalMin Mod 60 'minutes
'return value
WorkingHrsMins = intHours & ":" & intMinutes & ":" & IntSeconds
Exit_WorkingHrs:
Exit Function
Err_WorkingHrs:
Select Case Err
Case Else
MsgBox Err.Description
Resume Exit_WorkingHrs
End Select
End Function

**June7** · 05-11-2015, 01:45 PM

Please post code between CODE tags to retain indentation so will be more readable.

**dasousa** · 05-11-2015, 02:20 PM

how do i do that?

**June7** · 05-11-2015, 02:46 PM

Select and copy (ctrl+C) code from the VBA editor. Click the CODE button from tool menu above forum reply editor, paste code. Should see code between CODE tags. Can also manually type the tags.

**dasousa** · 05-11-2015, 02:57 PM

Code:

Public Function WorkingHrsMins(StartDate As Date, EndDate As Date) As String
'....................................................................
' Name:  WorkingHrs
' Inputs:   StartDate As Date & time
'  EndDate As Date & time
' Returns: Integer - number of hours not inclusive of weekends
' Author: Arvin Meyer
' Date:  February 19, 1997
' Modified by Steve S (ssanfu)
' Date: April 11, 2012
' Comment: Accepts two dates and returns the number
' of work hours and minutes between 8am and 8pm
' Note that this function does not account for holidays.
'....................................................................
   On Error GoTo Err_WorkingHrs
   Const cBeginingTime As Date = #8:00:00 AM#
   Const cEndingTime As Date = #8:00:00 PM#
   Dim intCountDays As Integer
   Dim intHours As Integer
   Dim intMinutes As Integer
   Dim intTotalMin As Integer
   Dim intTotalSec As Integer
   Dim dtStart As Date
   Dim dtEnd As Date
   Dim dtTemp As Date
   Dim tmStart As Date
   Dim tmEnd As Date
   intMinutes = 0
   intHours = 0
   IntSeconds = 0
   intCountDays = 0
   intTotalMin = 0
   WorkingHrsMins = 0
   'check end date > start date
   If EndDate < StartDate Then
      dtTemp = StartDate
      StartDate = EndDate
      EndDate = dtTemp
   End If
   'get just the date portion
   dtStart = Int(StartDate)
   dtEnd = Int(EndDate)
   'get just the time portion
   tmStart = StartDate - dtStart
   tmEnd = EndDate - dtEnd
   'check start and end times are valid
   If Not (tmStart >= cBeginingTime And tmStart <= cEndingTime) Then
      MsgBox "Invalid start time. Start time before " & cBeginingTime
      Exit Function
   ElseIf Not (tmEnd >= cBeginingTime And tmEnd <= cEndingTime) Then
      MsgBox "Invalid end time. End time after " & cEndingTime
      Exit Function
   End If
   If dtStart = dtEnd Then
      intTotalSec = DateDiff("s", tmStart, tmEnd)
   Else
      'skip the first day
      dtStart = dtStart + 1
      Do While dtStart < dtEnd
         'Make the above < and not <= to not count the EndDate
         Select Case Weekday(dtStart)
            Case Is = 1, 7
               'do nothing
            Case Is = 2, 3, 4, 5, 6
               intCountDays = intCountDays + 1
         End Select
         dtStart = dtStart + 1
      Loop
      intTotalSec = intCountDays * 720 * 60
      'first day minutes
      intTotalMin = intTotalMin + DateDiff("n", tmStart, cEndingTime)
      'Last day minutes
      intTotalMin = intTotalMin + DateDiff("n", cBeginingTime, tmEnd)

   End If
   intHours = intTotalMin \ 60   'hours
   intMinutes = intTotalMin Mod 60   'minutes
   'return value
   WorkingHrsMins = intHours & ":" & intMinutes & ":" & IntSeconds
Exit_WorkingHrs:
   Exit Function
Err_WorkingHrs:
   Select Case Err
      Case Else
         MsgBox Err.Description
         Resume Exit_WorkingHrs
   End Select
End Function

**June7** · 05-11-2015, 03:01 PM

Looks like dasousa posted your code with tags but does not appear to have made any changes to the logic. Consider these changes:

Change name of the function to WorkingHrsMinsSecs

intTotalSec = intCountDays * 720 * 60

intTotalSec = intTotalSec + DateDiff("s", tmStart, cEndingTime)

intTotalSec = intTotalSec + DateDiff("s", cBeginingTime, tmEnd)

WorkingHrsMinsSecs = Int(intTotalSec/3600) & ":" & Int((intTotalSec mod 3600) / 60) & ":" & Format(((intTotalSec mod 3600) / 60 - Int((intTotalSec mod 3600) / 60))*100,"00")

**dasousa** · 05-12-2015, 02:23 AM

Originally Posted by June7

Looks like dasousa posted your code with tags but does not appear to have made any changes to the logic. Consider these changes:

Change name of the function to WorkingHrsMinsSecs

intTotalSec = intCountDays * 720 * 60

intTotalSec = intTotalSec + DateDiff("s", tmStart, cEndingTime)

intTotalSec = intTotalSec + DateDiff("s", cBeginingTime, tmEnd)

WorkingHrsMinsSecs = Int(intTotalSec/3600) & ":" & Int((intTotalSec mod 3600) / 60) & ":" & Format(((intTotalSec mod 3600) / 60 - Int((intTotalSec mod 3600) / 60))*100,"00")

June/

Thanks for your replay,I try this code below

But i'm having this problems:

Examples:
Start Date Finish Date Result of function Result that i want to have
30-04-2015 13:14:23 30-04-2015 13:17:59 0:3:60 0:3:36
28-04-2015 20:04:51 28-04-2015 20:07:09 Error"invalid time" 00:00:00 Since time is (8:00PM to 08:00AM)
27-04-2015 14:27:08 29-04-2015 22:33:04 Error"invalid time" 29:32:52

My objective is to have a total os hh:mm:ss passed only during a time period (8:00AM to 8:00PM) and without weekends. Like a SLA that only is valid for Monday to Friday during the 8AM to 8PM

Code:

Public Function WorkingHrsMinsSecs(StartDate As Date, EndDate As Date) As String
'....................................................................
' Name:  WorkingHrs
' Inputs:   StartDate As Date & time
'  EndDate As Date & time
' Returns: Integer - number of hours not inclusive of weekends
' Author: Arvin Meyer
' Date:  February 19, 1997
' Modified by Steve S (ssanfu)
' Date: April 11, 2012
' Comment: Accepts two dates and returns the number
' of work hours and minutes between 8am and 8pm
' Note that this function does not account for holidays.
'....................................................................
   On Error GoTo Err_WorkingHrs
   Const cBeginingTime As Date = #8:00:00 AM#
   Const cEndingTime As Date = #8:00:00 PM#
   Dim intCountDays As Integer
   Dim intHours As Integer
   Dim intMinutes As Integer
   Dim intTotalMin As Integer
   Dim intTotalSec As Integer
   Dim dtStart As Date
   Dim dtEnd As Date
   Dim dtTemp As Date
   Dim tmStart As Date
   Dim tmEnd As Date
   intMinutes = 0
   intHours = 0
   IntSeconds = 0
   intCountDays = 0
   intTotalMin = 0
   WorkingHrsMins = 0
   'check end date > start date
   If EndDate < StartDate Then
      dtTemp = StartDate
      StartDate = EndDate
      EndDate = dtTemp
   End If
   'get just the date portion
   dtStart = Int(StartDate)
   dtEnd = Int(EndDate)
   'get just the time portion
   tmStart = StartDate - dtStart
   tmEnd = EndDate - dtEnd
   'check start and end times are valid
   If Not (tmStart >= cBeginingTime And tmStart <= cEndingTime) Then
     MsgBox "Invalid start time. Start time before " & cBeginingTime
      Exit Function
   ElseIf Not (tmEnd >= cBeginingTime And tmEnd <= cEndingTime) Then
      MsgBox "Invalid end time. End time after " & cEndingTime
      Exit Function
   End If
    
   If dtStart = dtEnd Then
      intTotalSec = DateDiff("s", tmStart, tmEnd)
   Else
      'skip the first day
      dtStart = dtStart + 1
      Do While dtStart < dtEnd
         'Make the above < and not <= to not count the EndDate
         Select Case Weekday(dtStart)
            Case Is = 1, 7
               'do nothing
            Case Is = 2, 3, 4, 5, 6
               intCountDays = intCountDays + 1
         End Select
         dtStart = dtStart + 1
      Loop
      intTotalSec = intCountDays * 720 * 60
      'first day minutes
      intTotalSec = intTotalSec + DateDiff("s", tmStart, cEndingTime)
      'Last day minutes
      intTotalSec = intTotalSec + DateDiff("s", cBeginingTime, tmEnd)
   End If
   intHours = intTotalMin \ 60   'hours
   intMinutes = intTotalMin Mod 60   'minutes
   'return value
   WorkingHrsMinsSecs = Int(intTotalSec / 3600) & ":" & Int((intTotalSec Mod 3600) / 60) & ":" & Format(((intTotalSec Mod 3600) / 60 - Int((intTotalSec Mod 3600) / 60)) * 100, "00")
Exit_WorkingHrs:
   Exit Function
Err_WorkingHrs:
   Select Case Err
      Case Else
         MsgBox Err.Description
         Resume Exit_WorkingHrs
   End Select
End Function

**June7** · 05-12-2015, 12:09 PM

You show date inputs in international format instead of Access structure. Review http://allenbrowne.com/ser-36.html

Learn debugging techniques, refer to link at bottom of my post. Step debug.

Sorry, error in seconds calculation. I thought sure had it right in that other thread.

intHours = intTotalSec \ 3600 'hours
intMinutes = Format(Int((intTotalSec Mod 3600) / 60), "00") 'minutes
intSeconds = Format(intTotalSec - (intHours * 3600 + intMinutes * 60), "00") 'seconds
'return value
WorkingHrsMinsSecs = intHours & ":" & intMinutes & ":" & intSeconds

**dasousa** · 05-12-2015, 12:31 PM

Originally Posted by June7

You show date inputs in international format instead of Access structure. Review http://allenbrowne.com/ser-36.html

Learn debugging techniques, refer to link at bottom of my post. Step debug.

Sorry, error in seconds calculation. I thought sure had it right in that other thread.

intHours = intTotalSec \ 3600 'hours
intMinutes = Format(Int((intTotalSec Mod 3600) / 60), "00") 'minutes
intSeconds = Format(intTotalSec - (intHours * 3600 + intMinutes * 60), "00") 'seconds
'return value
WorkingHrsMinsSecs = intHours & ":" & intMinutes & ":" & intSeconds

thanks,

I change the code, as past below and for the first example it became correct 0:3:36

But for the other two examples it contine to give error, it´s not possivel do have hours entry on the 8:00PM to 8:00AM

Code:

Public Function WorkingHrsMinsSecs(StartDate As Date, EndDate As Date) As String
'....................................................................
' Name:  WorkingHrs
' Inputs:   StartDate As Date & time
'  EndDate As Date & time
' Returns: Integer - number of hours not inclusive of weekends
' Author: Arvin Meyer
' Date:  February 19, 1997
' Modified by Steve S (ssanfu)
' Date: April 11, 2012
' Comment: Accepts two dates and returns the number
' of work hours and minutes between 8am and 8pm
' Note that this function does not account for holidays.
'....................................................................
   On Error GoTo Err_WorkingHrs
   Const cBeginingTime As Date = #8:00:00 AM#
   Const cEndingTime As Date = #8:00:00 PM#
   Dim intCountDays As Integer
   Dim intHours As Integer
   Dim intMinutes As Integer
   Dim intTotalMin As Integer
   Dim intTotalSec As Integer
   Dim dtStart As Date
   Dim dtEnd As Date
   Dim dtTemp As Date
   Dim tmStart As Date
   Dim tmEnd As Date
   intMinutes = 0
   intHours = 0
   intSeconds = 0
   intTotalSec = 0
   intCountDays = 0
   intTotalMin = 0
   WorkingHrsMinsSec = 0
   'check end date > start date
   If EndDate < StartDate Then
      dtTemp = StartDate
      StartDate = EndDate
      EndDate = dtTemp
   End If
   'get just the date portion
   dtStart = Int(StartDate)
   dtEnd = Int(EndDate)
   'get just the time portion
   tmStart = StartDate - dtStart
   tmEnd = EndDate - dtEnd
   'check start and end times are valid
   If Not (tmStart >= cBeginingTime And tmStart <= cEndingTime) Then
    MsgBox "Invalid start time. Start time before " & cBeginingTime
      Exit Function
   ElseIf Not (tmEnd >= cBeginingTime And tmEnd <= cEndingTime) Then
      MsgBox "Invalid end time. End time after " & cEndingTime
      Exit Function
   End If
    
   If dtStart = dtEnd Then
      intTotalSec = DateDiff("s", tmStart, tmEnd)
   Else
      'skip the first day
      dtStart = dtStart + 1
      Do While dtStart < dtEnd
         'Make the above < and not <= to not count the EndDate
         Select Case Weekday(dtStart)
            Case Is = 1, 7
               'do nothing
            Case Is = 2, 3, 4, 5, 6
               intCountDays = intCountDays + 1
         End Select
         dtStart = dtStart + 1
      Loop
      intTotalSec = intCountDays * 720 * 60
      'first day minutes
      intTotalSec = intTotalSec + DateDiff("s", tmStart, cEndingTime)
      'Last day minutes
      intTotalSec = intTotalSec + DateDiff("s", cBeginingTime, tmEnd)
   End If
   intHours = intTotalSec \ 3600   'hours
   intMinutes = Format(Int((intTotalSec Mod 3600) / 60), "00") 'minutes
    intSeconds = Format(intTotalSec - (intHours * 3600 + intMinutes * 60), "00") 'seconds

   'return value
   WorkingHrsMinsSecs = intHours & ":" & intMinutes & ":" & intSeconds
Exit_WorkingHrs:
   Exit Function
Err_WorkingHrs:
   Select Case Err
      Case Else
         MsgBox Err.Description
         Resume Exit_WorkingHrs
   End Select
End Function

**June7** · 05-12-2015, 02:58 PM

Well, that's the way the procedure is written. I don't know why. The code is working correctly as designed. It pops up message box and then returns a 0. The message box could be eliminated.

**dasousa** · 05-12-2015, 03:13 PM

but when i have more than 1 day of difference it gives "overflow"

it simes to be only workink for one day periord

Elapsed time hrs mins secs

Thread Tools

Elapsed time hrs mins secs

Similar Threads

calculate time elapsed

Elapsed Time by Area

Total elapsed time

Calculating Elapsed Time

Time Elapsed Problem

Posting Permissions