REVISION: This now allows for a choice of week end days (Default is Saturday and Sunday).
This function determines the number of business/working days between 2 dates; it ignores weekends (Saturday and Sunday) and accommodates Holidays, if you:
'Create a Table named tHoliday with a single DATE/TIME Field named [HolidayDate].
'Populate this Table with any and all work related Holidays.
'Inputs: StartDate, and EndDate, Optional WeekendDays
'
'DEFAULT WeekendDays is "1,7" which represent Saturday and Sunday
' based on 1 = sunday, 2 = monday, 3 = tuesday......7 = saturday
'
'Returns: an Integer representing the number of Workdays/Business Days
Code:
'---------------------------------------------------------------------------------------
' Procedure : fWorkingDays
' Author : --adapted from a Bytes article by A Dezii
' Date : 16/7/2015
' REVISED:5/4/2016
' Purpose :**UPDATED TO ALLOW CHOICE OF WEEKEND DAYS
' A Function to count the number of Workdays 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].
'Populate this Table with any and all work related Holidays.
'
'Inputs: StartDate, and EndDate, Optional WeekendDays
'
'DEFAULT WeekendDays is "1,7" which represent Saturday and Sunday
' based on 1 = sunday, 2 = monday, 3 = tuesday......7 = saturday
'
'Returns: an Integer representing the number of Workdays/Business Days
'
'There are debug.print statements (commented) that you can uncomment and follow the logic.
'---------------------------------------------------------------------------------------
'
Public Function fWorkingDays(dteStartDate As Date, dteEndDate As Date, Optional WeekendDays As String = "1,7") As Integer
Dim intCount As Integer
Dim wkdays As String
10 wkdays = "1234567" 'normal week days
20 intCount = 0
30 'Debug.Print "Weekend days " & WeekendDays
40 On Error GoTo fWorkingDays_Error
'process parameter
50 If Not WeekendDays Like "[1-9,][1-9,][1-9,]" Then
60 ' Debug.Print "**error in weekenddays " & WeekendDays
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"
70 Else
80 wkdays = Replace(wkdays, Left(WeekendDays, 1), "")
90 wkdays = Replace(wkdays, Right(WeekendDays, 1), "")
100 If Right(wkdays, 1) = "," Then wkdays = Mid(wkdays, 1, Len(wkdays) - 1)
110 'Debug.Print "using weekdays " & wkdays
120 End If
130
140 Do While dteStartDate <= dteEndDate
150 If InStr(WeekendDays, WeekDay(dteStartDate)) > 0 Then ' If a WeekEnd day do nothing
160 'Debug.Print "Testing days " & dteStartDate & " " & WeekDay(dteStartDate) & " is a weekendday"
170 Else
180 ' Debug.Print "Testing days " & dteStartDate & " " & WeekDay(dteStartDate) & " is a weekday"
' is it a Holiday as posted in tblHolidays?
190 If DCount("*", "tHoliday", "HolidayDate = #" & dteStartDate & "#") < 1 Then 'NOT Holiday
200 intCount = intCount + 1 ' so increment if weekday and not a holiday
210 Else
220 'Debug.Print "Testing weekdays " & WeekDay(dteStartDate) & " is a weekendday and a holiday " & dteStartDate
230 End If
240 End If
250 dteStartDate = dteStartDate + 1
260 Loop
270 fWorkingDays = intCount
280 On Error GoTo 0
290 Exit Function
fWorkingDays_Error:
300 MsgBox "Error " & Err.Number & " in line " & Erl & " (" & Err.Description & ") in procedure fWorkingDays of Module AWF_Related"
End Function
Here is a test routine showing a different set of Weekend days.
Code:
'---------------------------------------------------------------------------------------
' Procedure : testfWorkingDays
' Author : mellon
' Date : 4/05/2016
' Purpose :test routine for fWorkingDays
'Uses table tHoliday with this structure
'field_name data_type
' HolidayDate Date
' id Long
'
' For this test tHoliday is
'HolidayDate id
'25/03/2016 1 '...........Good Friday
'28/03/2016 2 '...........Easter Monday
'17/03/2016 3 '...........Made up Holidy for testing
'---------------------------------------------------------------------------------------
'
Sub testfWorkingDays()
10 On Error GoTo testfWorkingDays_Error
20 Debug.Print "Number of Working days in March 2016 --> " & fWorkingDays(#3/1/2016#, #3/31/2016#, "5,7")
30 On Error GoTo 0
40 Exit Sub
testfWorkingDays_Error:
50 MsgBox "Error " & Err.Number & " in line " & Erl & " (" & Err.Description & ") in procedure testWorkdays"
End Sub
Result:
Number of Working days in March 2016 --> 20