UPDATE: I have revised the function to
-deal with starting date or end date being a holiday
-added a parameter Dbug Boolean to show Debug.Prints
-default for Dbug is True
-Function returns a Single to allow for decimal hours.
Adjusted logic:
If startdate is a holiday, increment the startdate by 1 and reset the time to Midnight.
If enddate is a holiday, decrement the enddate by 1 and reset the time to 11:59:59 PM
The revised function
Code:
' ----------------------------------------------------------------
' Procedure Name: fWorkingDaysHrs
' Purpose: To return the number of business hours bewteen 2 dates.
' The total does not include weekend days nor Holidays that fall within
' the date range.
' Procedure Kind: Function
' Procedure Access: Public
' Parameter dteStartDate (Date): Starting date of the range includes Date and Time
' Parameter dteEndDate (Date): Ending date of the range includes Date and Time
' Parameter WeekendDays (String):Which days are weekend days default ( 1,7 Sun,Sat)
' Parameter Dbug (Boolean):True the debug, False don't do debug.print
' Return Type: Single "" changed to allow decimal values in total hours
' Author: Jack
' Date: 11-Feb-20
'
' This proceedure developed based on this post
' https://www.accessforums.net/showthread.php?t=79633&p=448065#post448065
'
' A Function to count the number of Workday Hours between 2 dates, that allows user to select weekend days
'and respects holidays
'Count of workings days returned does not include WeekEndDays nor Federal/Stat Holidays.
'
'Create a Table named tHoliday with a single DATE/TIME Field named [HolidayDate] with NO TIME Value.
'Populate this Table with any and all work related Holidays.
'
'Inputs: StartDate, and EndDate, Optional WeekendDays, Optional Dbug
'
'DEFAULT WeekendDays is "1,7" which represent Sunday and Saturday
' based on 1 = sunday, 2 = monday, 3 = tuesday......7 = saturday
'
'Returns: a Single representing the number of Workdays/Business Hours ******
'
'There are debug.print statements that are controllled by parameter Dbug
'---------------------------------------------------------------------------------------
'
Public Function fWorkingDaysHrs(dteStartDate As Date _
, dteEndDate As Date _
, Optional WeekendDays As String = "1,7" _
, Optional Dbug As Boolean = True) As Single 'new optional parameter!!!
10 On Error GoTo fWorkingDaysHrs_Error
Dim intCount As Integer 'count of days in range no weekends or holidays
Dim wkdays As String 'wkdays to be used based on user parms
Dim sDate As Date 'startDate without time portion
Dim eDate As Date 'enddate without time portion
'for final working hours calculation
Dim sDateHours As Single 'starttime until midnight first day
Dim eDateHours As Single 'midnight to endtime last day
20 sDate = DateValue(dteStartDate) 'only the Date -no time- for startDate
30 eDate = DateValue(dteEndDate) 'only the Date -no time- for endDate
Dim FullWorkingDays As Integer 'total full workingdays
40 wkdays = "1234567" 'normal week days
50 intCount = 0
60 If Dbug Then Debug.Print "Weekend days " & WeekendDays
70 If Dbug Then Debug.Print "StartDate is " & dteStartDate & vbCrLf _
& "EndDate is " & dteEndDate
'process Optional parameter 3 chars
80 If Not WeekendDays Like "[1-9,][1-9,][1-9,]" Then
'Debug.Print "**error in weekenddays " & WeekendDays
90 Err.Raise 2000, , "Bad value in WeekendDays - must be x,x where x is number 1 thru 7" _
& " representing the week end days 1 = sunday 2 = monday 3 = tuesday......7 = saturday"
100 Else
110 wkdays = Replace(wkdays, Left(WeekendDays, 1), "")
120 wkdays = Replace(wkdays, Right(WeekendDays, 1), "")
130 If Right(wkdays, 1) = "," Then wkdays = Mid(wkdays, 1, Len(wkdays) - 1)
140 If Dbug Then Debug.Print "using weekdays " & wkdays
150 End If
' ********* check if startdate is a holiday ***********
' ********* ***********
'*****************************************************
160 If DCount("*", "tHoliday", "HolidayDate = #" & sDate & "#") = 1 Then
170 If Dbug Then Debug.Print "Startdate is a holiday so time is not factor " & vbCrLf _
& " increment startdate 1 day and set time to midnight"
180 dteStartDate = DateAdd("d", 1, DateValue(dteStartDate)) + TimeSerial(0, 0, 0)
190 If Dbug Then Debug.Print "revised startdate is " & dteStartDate & " " & TimeValue(dteStartDate)
200 sDate = DateValue(dteStartDate)
210 Else
220 If Dbug Then Debug.Print "Startdate is not a holiday --carry on!"
230 End If
' ********* check if EndDate is a holiday ***********
' ********* ***********
'****************************************************
240 If DCount("*", "tHoliday", "HolidayDate = #" & eDate & "#") = 1 Then
250 If Dbug Then Debug.Print "Enddate is a holiday so time is not factor " & vbCrLf _
& " decrement dteEndDate by 1 and reset enddate time to midnight"
260 dteEndDate = DateAdd("d", -1, DateValue(dteEndDate)) + TimeSerial(23, 59, 59)
270 If Dbug Then Debug.Print "revised enddate is " & dteEndDate & " " & TimeValue(dteEndDate)
280 eDate = DateValue(dteEndDate)
290 Else
300 If Dbug Then Debug.Print "Enddate is not a holiday --carry on!"
310 End If
'iterate over the Start and End Dates to identiy weekend day, weekday or holiday
320 Do While sDate <= eDate
330 If InStr(WeekendDays, Weekday(sDate)) > 0 Then ' If a WeekEnd day do nothing
340 If Dbug Then Debug.Print "Testing days " & sDate & " " & Weekday(sDate) & " is a weekendday"
350 ElseIf DCount("*", "tHoliday", "HolidayDate = #" & sDate & "#") = 1 Then 'is a Holiday
360 If Dbug Then Debug.Print "Testing weekdays " & Weekday(sDate) & " " & sDate _
& " is a " & WeekdayName(Weekday(sDate)) & " weekday and a Holiday "
370 Else 'weekday not a holiday
380 intCount = intCount + 1 ' so increment if weekday and not a holiday
390 If Dbug Then Debug.Print "Testing weekdays " & Weekday(sDate) & " " & sDate _
& " is a " & WeekdayName(Weekday(sDate)) & " not a holiday "
400 End If
410 sDate = sDate + 1
420 Loop
430 FullWorkingDays = intCount 'this is the full days count; previously return value
' new logic to handle hours
' need to get hours fro first day and last day
'hours attributed to startDate
440 sDateHours = DateDiff("n", TimeValue(dteStartDate), #11:59:59 PM#)
450 eDateHours = DateDiff("n", TimeValue(dteEndDate), #11:59:59 PM#)
460 If Dbug Then Debug.Print "sdatehours " & sDateHours & vbCrLf & "edatehours " & 1440 - eDateHours
470 If Dbug Then Debug.Print "Full time in hours no weekends, no holidays " _
& ((FullWorkingDays * 1440) + sDateHours - (1440 + eDateHours)) / 60
480 fWorkingDaysHrs = ((FullWorkingDays * 1440) + sDateHours - (1440 + eDateHours)) / 60 'for hours
490 On Error GoTo 0
fWorkingDaysHrs_Exit:
500 Exit Function
fWorkingDaysHrs_Error:
510 MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fWorkingDaysHrs, line " & Erl & "."
520 GoTo fWorkingDaysHrs_Exit
End Function
TEST ROUTINE:
Code:
Sub testhours()
'need to deal with days, then adjust at end with
'min differences between start on startdate and midnight
'and same for end date
Dim sDatex As Date: sDatex = #12/30/2019 3:15:00 PM#
Dim eDatex As Date: eDatex = #1/2/2020 9:15:00 AM#
Debug.Print "total Hours " & fWorkingDaysHrs(sDatex, eDatex, "1,7")
End Sub
Result of test routine
Code:
using weekdays 23456
Startdate is not a holiday --carry on!
Enddate is not a holiday --carry on!
Testing weekdays 2 30-Dec-19 is a Monday not a holiday
Testing weekdays 3 31-Dec-19 is a Tuesday not a holiday
Testing weekdays 4 01-Jan-20 is a Wednesday weekday and a Holiday
Testing weekdays 5 02-Jan-20 is a Thursday not a holiday
sdatehours 524
edatehours 556
Full time in hours no weekends, no holidays 42
total Hours 42
Good luck with your project.