Public Function WorkDay(ByVal start_date As Date, ByVal days As Long, Optional ByVal weekend As Integer = 0, Optional ByVal holidays As Boolean = False) As Date
' Custom WorkDay calculation function like MS Excel's Workday.Intl()
'
' Author : Adil Kocaosmanlar // adilkocaosmanlar@gmail.com
' Date : 2019/09/19
' Usage : WorkDay(start_date, days, weekend, holidays)
' - start_date : Required. The start date, truncated to integer.
' - days : Required. The number of workdays before or after the start_date. A positive value yields a future date;
' a negative value yields a past date; a zero value yields the start_date. Day-offset is truncated to an integer.
' - weekend : Optional. Indicates the days of the week that are weekend days and are not considered working days. Weekend is
' a weekend number or string that specifies when weekends occur.Weekend number values indicate the following
' weekend days:
' 1 - Saturday, Sunday
' 2 - Sunday, Monday
' 3 - Monday, Tuesday
' 4 - Tuesday, Wednesday
' 5 - Wednesday, Thursday
' 6 - Thusday, Friday
' 7 - Friday, Saturday
' 11 - Sunday only
' 12 - Monday only
' 13 - Tuesday only
' 14 - Wednesday only
' 15 - Thursday only
' 16 - Friday only
' 17 - Saturday only
' - holidays : Optional. An optional set of one or more dates that are to be excluded from the working day calendar. Holidays
' shall be defined in tbl_holidays table. The ordering of dates in holidays can be arbitrary.
'
' Example : WorkDay("2019/09/19", 3, 1, True)
On Error GoTo Err_Procedure
Dim n As Long
Dim NextDate As Date
Dim Step As Long
Dim HolidayMatchCount As Long
If (weekend > 0 And weekend < 8) Or (weekend > 10 And weekend < 18) Then
n = 0
Step = Sgn(days)
NextDate = Format(start_date, "yyyy-mm-dd", vbMonday, vbFirstFourDays)
Do Until n >= Abs(days)
NextDate = NextDate + Step
If holidays Then ' Count all work days except holidays defined in tbl_holidays table.
HolidayMatchCount = DCount("holiday_date", "tbl_holidays", "holiday_date = #" & Format(NextDate, "yyyy-mm-dd", vbMonday, vbFirstFourDays) & "#")
Select Case weekend
Case 1 ' Saturday, Sunday and Holiday
If Weekday(NextDate) <> vbSaturday And Weekday(NextDate) <> vbSunday And HolidayMatchCount < 1 Then n = n + 1
Case 2 ' Sunday, Monday and Holiday
If Weekday(NextDate) <> vbSunday And Weekday(NextDate) <> vbMonday And HolidayMatchCount < 1 Then n = n + 1
Case 3 ' Monday, Tuesday and Holiday
If Weekday(NextDate) <> vbMonday And Weekday(NextDate) <> vbTuesday And HolidayMatchCount < 1 Then n = n + 1
Case 4 ' Tuesday, Wednesday and Holiday
If Weekday(NextDate) <> vbTuesday And Weekday(NextDate) <> vbWednesday And HolidayMatchCount < 1 Then n = n + 1
Case 5 ' Wednesday, Thursday and Holiday
If Weekday(NextDate) <> vbWednesday And Weekday(NextDate) <> vbThursday And HolidayMatchCount < 1 Then n = n + 1
Case 6 ' Thursday, Friday and Holiday
If Weekday(NextDate) <> vbThursday And Weekday(NextDate) <> vbFriday And HolidayMatchCount < 1 Then n = n + 1
Case 7 ' Friday, Saturday and Holiday
If Weekday(NextDate) <> vbFriday And Weekday(NextDate) <> vbSaturday And HolidayMatchCount < 1 Then n = n + 1
Case 11 ' Sunday and Holiday
If Weekday(NextDate) <> vbSunday And HolidayMatchCount < 1 Then n = n + 1
Case 12 ' Monday and Holiday
If Weekday(NextDate) <> vbMonday And HolidayMatchCount < 1 Then n = n + 1
Case 13 ' Tuesday and Holiday
If Weekday(NextDate) <> vbTuesday And HolidayMatchCount < 1 Then n = n + 1
Case 14 ' Wednesday and Holiday
If Weekday(NextDate) <> vbWednesday And HolidayMatchCount < 1 Then n = n + 1
Case 15 ' Thursday and Holiday
If Weekday(NextDate) <> vbThursday And HolidayMatchCount < 1 Then n = n + 1
Case 16 ' Friday and Holiday
If Weekday(NextDate) <> vbFriday And HolidayMatchCount < 1 Then n = n + 1
Case 17 ' Saturday and Holiday
If Weekday(NextDate) <> vbSaturday And HolidayMatchCount < 1 Then n = n + 1
End Select
Else ' Count all work days.
Select Case weekend
Case 1 ' Saturday, Sunday
If Weekday(NextDate) <> vbSaturday And Weekday(NextDate) <> vbSunday Then n = n + 1
Case 2 ' Sunday, Monday
If Weekday(NextDate) <> vbSunday And Weekday(NextDate) <> vbMonday Then n = n + 1
Case 3 ' Monday, Tuesday
If Weekday(NextDate) <> vbMonday And Weekday(NextDate) <> vbTuesday Then n = n + 1
Case 4 ' Tuesday, Wednesday
If Weekday(NextDate) <> vbTuesday And Weekday(NextDate) <> vbWednesday Then n = n + 1
Case 5 ' Wednesday, Thursday
If Weekday(NextDate) <> vbWednesday And Weekday(NextDate) <> vbThursday Then n = n + 1
Case 6 ' Thursday, Friday
If Weekday(NextDate) <> vbThursday And Weekday(NextDate) <> vbFriday Then n = n + 1
Case 7 ' Friday, Saturday
If Weekday(NextDate) <> vbFriday And Weekday(NextDate) <> vbSaturday Then n = n + 1
Case 11 ' Sunday only
If Weekday(NextDate) <> vbSunday Then n = n + 1
Case 12 ' Monday only
If Weekday(NextDate) <> vbMonday Then n = n + 1
Case 13 ' Tuesday only
If Weekday(NextDate) <> vbTuesday Then n = n + 1
Case 14 ' Wednesday only
If Weekday(NextDate) <> vbWednesday Then n = n + 1
Case 15 ' Thursday only
If Weekday(NextDate) <> vbThursday Then n = n + 1
Case 16 ' Friday only
If Weekday(NextDate) <> vbFriday Then n = n + 1
Case 17 ' Saturday only
If Weekday(NextDate) <> vbSaturday Then n = n + 1
End Select
End If
Loop
WorkDay = NextDate
Else
If holidays Then ' Count all days except holidays defined in tbl_holidays.
n = 0
Step = Sgn(days)
NextDate = Format(start_date, "yyyy-mm-dd", vbMonday, vbFirstFourDays)
Do Until n >= Abs(days)
NextDate = NextDate + Step
HolidayMatchCount = DCount("holiday_date", "tbl_Holidays", "holiday_date = #" & Format(NextDate, "yyyy-mm-dd", vbMonday, vbFirstFourDays) & "#")
If HolidayMatchCount < 1 Then n = n + 1
Loop
WorkDay = NextDate
Else ' Count all days.
WorkDay = DateAdd("d", days, Format(start_date, "yyyy-mm-dd", vbMonday, vbFirstFourDays))
End If
End If
Exit_Procedure:
Exit Function
Err_Procedure:
Dim strErrorMessage As String
Select Case Err.Number
Case 0 'Everything is fine :)
Case Else
strErrorMessage = "We got an unexpected error, please note these details:" & vbCrLf & _
"Error number: " & Err.Number & vbCrLf & _
"Error description: " & Err.Description & vbCrLf & _
"Error source: " & Err.Source & vbCrLf & _
"Session: " & Environ("computername") & "\" & Environ("username")
End Select
Debug.Print strErrorMessage
Resume Exit_Procedure
End Function