VBA Function used by Query isn't Calculating Date Expected - vba

Question

The code and query that I am using to calculate a future due date is working correctly, but when I attempt to use the same logic to calculate a required by date, the date that is being returned is the Start Date and not the Required by Date.
When I calculate a DateDue based on a StartDate of 8/1/19 with the NumDays as 30, the date that is calculated is 9/13/19 when weekends and holidays are excluded.
DateDue: AddWorkDays([StartDate],[NumDays])
When I try to alter this to look back to calculate a NeededBy date, the StartDate of 8/1/19 with the NumDays as 30, the date that us being returned is 8/1/19 and I would expect to see 6/17/19.
NeededBy: AddWorkDays([StartDate],-[NumDays])
Public Function AddWorkDays(StartDate As Date, NumDays As Integer) As Date
Dim rst As DAO.Recordset
Dim dbs As DAO.Database
Dim dtmCurr As Date
Dim intCount As Integer
On Error GoTo ErrHandler
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("tblHolidays", dbOpenSnapshot)
intCount = 0
dtmCurr = StartDate
Do While intCount < NumDays
dtmCurr = dtmCurr + 1
If Weekday(dtmCurr, vbMonday) < 6 Then
rst.FindFirst "[HolidayDate] = #" & Format(dtmCurr, "mm\/dd\/yyyy") & "#"
If rst.NoMatch Then
intCount = intCount + 1
End If
End If
Loop
AddWorkDays = dtmCurr
ExitHandler:
rst.Close
Set rst = Nothing
Set dbs = Nothing
Exit Function
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Function
This calculates a correct future date:
DateDue: AddWorkDays([StartDate],[NumDays])
I would expect this to return the StartDate - NumDays and exclude weekends and holidays, but it is returning the StartDate:
NeededBy: AddWorkDays([StartDate],-[NumDays])

Answer 1

If NumDays is negative the test expression for the Do While loop will never be validated, since intCount = 0 which is greater than NumDays.
intCount < NumDays
As such, the loop will not be evaluated and dtmCurr will remain equal to StartDate.
To count the days back, you'll need to alter the function to include logic which subtracts days from the variable dtmCurr, since the current function is hardcoded to add them:
dtmCurr = dtmCurr + 1
After a cursory review of the code, you could change:
Do While intCount < NumDays
To:
Do While intCount < Abs(NumDays)
And:
dtmCurr = dtmCurr + 1
To:
dtmCurr = dtmCurr + Sgn(NumDays)

Answer 2

You can use my function. It will count both back and forth:
Option Explicit
' Common constants.
' Date.
Public Const DaysPerWeek As Long = 7
Public Const MaxDateValue As Date = #12/31/9999#
Public Const MinDateValue As Date = #1/1/100#
' Workdays per week.
Public Const WorkDaysPerWeek As Long = 5
' Average count of holidays per week maximum.
Public Const HolidaysPerWeek As Long = 1
' 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.
'
' 2015-12-19. 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.
MaxDayDiff = Number * DaysPerWeek / (WorkDaysPerWeek - HolidaysPerWeek)
' 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 = GetHolidays(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
' Returns the holidays between Date1 and Date2.
' The holidays are returned as a recordset with the
' dates ordered ascending, optionally descending.
'
' Requires table Holiday with list of holidays.
'
' 2015-12-18. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function DatesHoliday( _
ByVal Date1 As Date, _
ByVal Date2 As Date, _
Optional ByVal ReverseOrder As Boolean) _
As DAO.Recordset
' The table that holds the holidays.
Const Table As String = "Holiday"
' The field of the table that holds the dates of the holidays.
Const Field As String = "Date"
Dim rs As DAO.Recordset
Dim SQL As String
Dim SqlDate1 As String
Dim SqlDate2 As String
Dim Order As String
SqlDate1 = Format(Date1, "\#yyyy\/mm\/dd\#")
SqlDate2 = Format(Date2, "\#yyyy\/mm\/dd\#")
ReverseOrder = ReverseOrder Xor (DateDiff("d", Date1, Date2) < 0)
Order = IIf(ReverseOrder, "Desc", "Asc")
SQL = "Select " & Field & " From " & Table & " " & _
"Where " & Field & " Between " & SqlDate1 & " And " & SqlDate2 & " " & _
"Order By 1 " & Order
Set rs = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)
Set DatesHoliday = rs
End Function
' Returns the holidays between Date1 and Date2.
' The holidays are returned as an array with the
' dates ordered ascending, optionally descending.
'
' The array is declared static to speed up
' repeated calls with identical date parameters.
'
' Requires table Holiday with list of holidays.
'
' 2015-12-18. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function GetHolidays( _
ByVal Date1 As Date, _
ByVal Date2 As Date, _
Optional ByVal OrderDesc As Boolean) _
As Date()
' Constants for the arrays.
Const DimRecordCount As Long = 2
Const DimFieldOne As Long = 0
Static Date1Last As Date
Static Date2Last As Date
Static OrderLast As Boolean
Static DayRows As Variant
Static Days As Long
Dim rs As DAO.Recordset
' Cannot be declared Static.
Dim Holidays() As Date
If DateDiff("d", Date1, Date1Last) <> 0 Or _
DateDiff("d", Date2, Date2Last) <> 0 Or _
OrderDesc <> OrderLast Then
' Retrieve new range of holidays.
Set rs = DatesHoliday(Date1, Date2, OrderDesc)
' Save the current set of date parameters.
Date1Last = Date1
Date2Last = Date2
OrderLast = OrderDesc
Days = rs.RecordCount
If Days > 0 Then
' As repeated calls may happen, do a movefirst.
rs.MoveFirst
DayRows = rs.GetRows(Days)
' rs is now positioned at the last record.
End If
rs.Close
End If
If Days = 0 Then
' Leave Holidays() as an unassigned array.
Erase Holidays
Else
' Fill array to return.
ReDim Holidays(Days - 1)
For Days = LBound(DayRows, DimRecordCount) To UBound(DayRows, DimRecordCount)
Holidays(Days) = DayRows(DimFieldOne, Days)
Next
End If
Set rs = Nothing
GetHolidays = Holidays()
End Function