I picked up the functions below for adding working days (excluding holidays) to a date based on a lag.
This has been working perfectly until now. I have stepped through the code and the dates look to be formatting in the same way and everything else looks to be doing what it should (however I am not an expert).
The issue I am having is that 1 June 2020 is a public holiday. I am in New Zealand where we format dates as dd/mm/yyyy
When I set DelDateDoors to be 02/06/2020 and the Lag = 2, I get a production date of 27/05/2020 as expected, however if I set DelDateDoors to 03/06/2020 I get a Production date of 29/05/2020 which to me means it is not excluding the public holiday on the 1st.
I initially thought it may be that the day and month were being switched at some point but I didn't see it happening on the step through. We also have a public holiday on the 2nd february (02/06/2020) so maybe that is why the above works for a delivery date of 02/06/2020.
I have spent much time reading forums and stepping through many examples to see if I can diagnose the issue myself but have had no luck yet. I have recently added a date dimension table to my database so would even be open to a better way of doing this calculation if that's what I should do.
Any help is much appreciated!
This has been working perfectly until now. I have stepped through the code and the dates look to be formatting in the same way and everything else looks to be doing what it should (however I am not an expert).
The issue I am having is that 1 June 2020 is a public holiday. I am in New Zealand where we format dates as dd/mm/yyyy
When I set DelDateDoors to be 02/06/2020 and the Lag = 2, I get a production date of 27/05/2020 as expected, however if I set DelDateDoors to 03/06/2020 I get a Production date of 29/05/2020 which to me means it is not excluding the public holiday on the 1st.
I initially thought it may be that the day and month were being switched at some point but I didn't see it happening on the step through. We also have a public holiday on the 2nd february (02/06/2020) so maybe that is why the above works for a delivery date of 02/06/2020.
I have spent much time reading forums and stepping through many examples to see if I can diagnose the issue myself but have had no luck yet. I have recently added a date dimension table to my database so would even be open to a better way of doing this calculation if that's what I should do.
Any help is much appreciated!
Code:
Private Sub DelDateDoors_AfterUpdate()
On Error GoTo cmdProdDate_ClickErr
Me.Lag = Me.DeliveryType.Column(1)
Me.ProductionDate = DateAddWorkdays(-Me.Lag, Me.DelDateDoors, False)
Exit Sub
cmdProdDate_ClickErr:
MsgBox ("Click Error " & Err.Number & " " & Err.Description)
End Sub
Public Function NotWorkday(dteDate As Date) As Boolean
'strDate1 = Format(datDate, "\#yyyy\/mm\/dd\#")
If Weekday(dteDate, vbMonday) > 5 Then
NotWorkday = True
Exit Function
ElseIf Not IsNull(DLookup("[HolidayDate]", "tblHoliday", "[HolidayDate] = #" & Format(dteDate, "yyyy\/mm\/dd") & "#")) Then
NotWorkday = True
Exit Function
End If
NotWorkday = False
End Function
Option Compare Database
Public Function DateAddWorkdays( _
ByVal lngNumber As Long, _
ByVal datDate As Date, _
Optional ByVal booWorkOnHolidays As Boolean) _
As Date
' Adds lngNumber of workdays to datDate.
' 2014-10-03. Cactus Data ApS, CPH
' Calendar days per week.
Const clngWeekdayCount As Long = 7
' Workdays per week.
Const clngWeekWorkdays As Long = 5
' Average count of holidays per week maximum.
Const clngWeekHolidays As Long = 1
' Maximum valid date value.
Const cdatDateRangeMax As Date = #12/31/9999#
' Minimum valid date value.
Const cdatDateRangeMin As Date = #1/1/100#
Dim aHolidays() As Date
Dim lngDays As Long
Dim lngDiff As Long
Dim lngDiffMax As Long
Dim lngSign As Long
Dim datDate1 As Date
Dim datDate2 As Date
Dim datLimit As Date
Dim lngHoliday As Long
lngSign = Sgn(lngNumber)
datDate2 = datDate
If lngSign <> 0 Then
If booWorkOnHolidays = True Then
' Holidays are workdays.
Else
' Retrieve array with holidays between datDate and datDate + lngDiffMax.
' Calculate the maximum calendar days per workweek.
lngDiffMax = lngNumber * clngWeekdayCount / (clngWeekWorkdays - clngWeekHolidays)
' Add one week to cover cases where a week contains multiple holidays.
lngDiffMax = lngDiffMax + Sgn(lngDiffMax) * clngWeekdayCount
datDate1 = DateAdd("d", lngDiffMax, datDate)
aHolidays = GetHolidays(datDate, datDate1)
End If
Do Until lngDays = lngNumber
If lngSign = 1 Then
datLimit = cdatDateRangeMax
Else
datLimit = cdatDateRangeMin
End If
If DateDiff("d", DateAdd("d", lngDiff, datDate), datLimit) = 0 Then
' Limit of date range has been reached.
Exit Do
End If
lngDiff = lngDiff + lngSign
datDate2 = DateAdd("d", lngDiff, datDate)
Select Case Weekday(datDate2)
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 lngHoliday = LBound(aHolidays) To UBound(aHolidays)
If Err.Number > 0 Then
' No holidays between datDate and datDate1.
ElseIf DateDiff("d", datDate2, aHolidays(lngHoliday)) = 0 Then
' This datDate2 hits a holiday.
' Subtract one day before adding one after the loop.
lngDays = lngDays - lngSign
Exit For
End If
Next
On Error GoTo 0
lngDays = lngDays + lngSign
End Select
Loop
End If
DateAddWorkdays = datDate2
End Function
Public Function GetHolidays( _
ByVal datDate1 As Date, _
ByVal datDate2 As Date, _
Optional ByVal booDesc As Boolean) _
As Date()
' Finds the count of holidays between datDate1 and datDate2.
' The holidays are returned as an array of dates.
' DAO objects are declared static to speed up repeated calls with identical date parameters.
' 2014-10-03. Cactus Data ApS, CPH
' The table that holds the holidays.
Const cstrTable As String = "tblHoliday"
' The field of the table that holds the dates of the holidays.
Const cstrField As String = "HolidayDate"
' Constants for the arrays.
Const clngDimRecordCount As Long = 2
Const clngDimFieldOne As Long = 0
Static dbs As DAO.Database
Static rst As DAO.Recordset
Static datDate1Last As Date
Static datDate2Last As Date
Dim adatDays() As Date
Dim avarDays As Variant
Dim strSQL As String
Dim strDate1 As String
Dim strDate2 As String
Dim strOrder As String
Dim lngDays As Long
If DateDiff("d", datDate1, datDate1Last) <> 0 Or DateDiff("d", datDate2, datDate2Last) <> 0 Then
' datDate1 or datDate2 has changed since the last call.
strDate1 = Format(datDate1, "\#yyyy\/mm\/dd\#")
strDate2 = Format(datDate2, "\#yyyy\/mm\/dd\#")
strOrder = Format(booDesc, "\A\s\c;\D\e\s\c")
strSQL = "Select " & cstrField & " From " & cstrTable & " " & _
"Where " & cstrField & " Between " & strDate1 & " And " & strDate2 & " " & _
"Order By 1 " & strOrder
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
Debug.Print strSQL
' Save the current set of date parameters.
datDate1Last = datDate1
datDate2Last = datDate2
End If
lngDays = rst.RecordCount
If lngDays = 0 Then
' Leave adatDays() as an unassigned array.
Else
ReDim adatDays(lngDays - 1)
' As repeated calls may happen, do a movefirst.
rst.MoveFirst
avarDays = rst.GetRows(lngDays)
' rst is now positioned at the last record.
For lngDays = LBound(avarDays, clngDimRecordCount) To UBound(avarDays, clngDimRecordCount)
adatDays(lngDays) = avarDays(clngDimFieldOne, lngDays)
Next
End If
' DAO objects are static.
' Set rst = Nothing
' Set dbs = Nothing
GetHolidays = adatDays()
End Function