Find end date given startdate in MS ACCESS - vba

Question

I'm attempting to write a formula that rounds an end date it to the nearest workday given the start date. I will want the flexibility to add the number of days to start date. For example, if I have the dates November 27, 2021 (which is a Saturday) and November 28, 2021 (which is a Sunday) I want the formula to return November 29, 2021 (Monday). However, if the date November 26, 2021 return same date since it’s a working day. The date will also move to the next working day if the Date is a holiday. Thanks
Public Function AddDueDate(StartDate As Date, TotalPeriold As Integer) As Date
Dim rst As Recordset
Dim db As Database
Dim Duedate As Date
Dim icount As Integer
On Error GoTo errhandlers:
Set db = CurrentDb
Set rst = db.OpenRecordset("tblHolidays", dbOpenSnapshot)
icount = 0
Duedate = StartDate
Do While icount < TotalPeriod
Duedate = Duedate + 1
If Weekday(Duedate, vbMonday) < 6 Then
rst.FindFirst "[Holidaydate]=#" & Duedate & "#"
If rst.NoMatch Then
icount = icount + 1
End If
End If
Loop
AddDueDate = Duedate
exit_errhandlers:
rst.Close
Set rst = Nothing
Set db = Nothing
Exit Function
errhandlers:
MsgBox Err.Description, vbExclamation
Resume Next
End Function

Answer 1

You can obtain that with a combo of my functions found in my project at VBA.Date:
WorkdayDate = DateAddWorkdays(Abs(Not IsDateWorkday(YourDate)), YourDate)
which will add zero days to a date of a workday but, for a non-workday, return the following date of workday.
Full code is too much to post here, but this is the core function:
' Adds Number of full workdays to Date1 and returns the found date.
' Number can be positive, zero, or negative.
' Optionally, if WorkOnHolidays is True, holidays are counted as workdays.
'
' For excessive parameters that would return dates outside the range
' of Date, either 100-01-01 or 9999-12-31 is returned.
'
' Will add 500 workdays in about 0.01 second.
'
' Requires table Holiday with list of holidays.
'
' 2021-12-09. Gustav Brock. Cactus Data ApS, CPH.
'
Public Function DateAddWorkdays( _
ByVal Number As Long, _
ByVal Date1 As Date, _
Optional ByVal WorkOnHolidays As Boolean) _
As Date
Const Interval As String = "d"
Dim Holidays() As Date
Dim Days As Long
Dim DayDiff As Long
Dim MaxDayDiff As Long
Dim Sign As Long
Dim Date2 As Date
Dim NextDate As Date
Dim DateLimit As Date
Dim HolidayId As Long
Sign = Sgn(Number)
NextDate = Date1
If Sign <> 0 Then
If WorkOnHolidays = True Then
' Holidays are workdays.
Else
' Retrieve array with holidays between Date1 and Date1 + MaxDayDiff.
' Calculate the maximum calendar days per workweek.
If (WorkDaysPerWeek - HolidaysPerWeek) > 1 Then
MaxDayDiff = Number * DaysPerWeek / (WorkDaysPerWeek - HolidaysPerWeek)
Else
MaxDayDiff = Number * DaysPerWeek
End If
' Add one week to cover cases where a week contains multiple holidays.
MaxDayDiff = MaxDayDiff + Sgn(MaxDayDiff) * DaysPerWeek
If Sign > 0 Then
If DateDiff(Interval, Date1, MaxDateValue) < MaxDayDiff Then
MaxDayDiff = DateDiff(Interval, Date1, MaxDateValue)
End If
Else
If DateDiff(Interval, Date1, MinDateValue) > MaxDayDiff Then
MaxDayDiff = DateDiff(Interval, Date1, MinDateValue)
End If
End If
Date2 = DateAdd(Interval, MaxDayDiff, Date1)
' Retrive array with holidays.
Holidays = DatesHoliday(Date1, Date2)
End If
Do Until Days = Number
If Sign = 1 Then
DateLimit = MaxDateValue
Else
DateLimit = MinDateValue
End If
If DateDiff(Interval, DateAdd(Interval, DayDiff, Date1), DateLimit) = 0 Then
' Limit of date range has been reached.
Exit Do
End If
DayDiff = DayDiff + Sign
NextDate = DateAdd(Interval, DayDiff, Date1)
Select Case Weekday(NextDate)
Case vbSaturday, vbSunday
' Skip weekend.
Case Else
' Check for holidays to skip.
' Ignore error when using LBound and UBound on an unassigned array.
On Error Resume Next
For HolidayId = LBound(Holidays) To UBound(Holidays)
If Err.Number > 0 Then
' No holidays between Date1 and Date2.
ElseIf DateDiff(Interval, NextDate, Holidays(HolidayId)) = 0 Then
' This NextDate hits a holiday.
' Subtract one day before adding one after the loop.
Days = Days - Sign
Exit For
End If
Next
On Error GoTo 0
Days = Days + Sign
End Select
Loop
End If
DateAddWorkdays = NextDate
End Function