Adding working days to a date, not calculating correctly every time (1 Viewer)

Integrate

Registered User.
Local time
Tomorrow, 02:51
Joined
Oct 20, 2013
Messages
27
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!

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
 

theDBguy

I’m here to help
Staff member
Local time
Today, 05:51
Joined
Oct 29, 2018
Messages
13,718
Hi. Just checking, are you sure June 1st is listed in the Holidays table?
 

arnelgp

error reading drive A:
Local time
Today, 21:51
Joined
May 7, 2009
Messages
11,130
it is better to re-create the function, instead of debugging:
Code:
Public Function DateAddWorkdays( _
    ByVal lngNumber As Long, _
    ByVal datDate As Date) _
    As Date
    Dim subtrahend As Integer
    
If lngNumber < 0 Or lngNumber > 0 Then
    subtrahend = IIf(lngNumber > 0, 1, -1)
    While NotWorkday(datDate)
        datDate = DateAdd("d", subtrahend, datDate)
    Wend
    Do While lngNumber <> 0
        datDate = DateAdd("d", subtrahend, datDate)
        If NotWorkday(datDate) = False Then
            lngNumber = lngNumber + (subtrahend * (-1))
        End If
    Loop
Else
    While NotWorkday(datDate)
        datDate = DateAdd("d", 1, datDate)
    Wend
End If
DateAddWorkdays = datDate

End Function


Public Function NotWorkday(dteDate As Date) As Boolean
'strDate1 = Format(datDate, "\#yyyy\/mm\/dd\#")
NotWorkday = False
If Weekday(dteDate, vbMonday) > 5 Then
    NotWorkday = True
ElseIf DCount("1", "tblHoliday", "HolidayDate = #" & Format(dteDate, "mm/dd/yyyy") & "#") > 0 Then
    NotWorkday = True
End If
End Function
 

Integrate

Registered User.
Local time
Tomorrow, 02:51
Joined
Oct 20, 2013
Messages
27
Hi. Just checking, are you sure June 1st is listed in the Holidays table?

Yes, the date is in the table as this:

ID HolidayDate
19 2020-06-01 00:00:00.000

1589099143294.png
 

Integrate

Registered User.
Local time
Tomorrow, 02:51
Joined
Oct 20, 2013
Messages
27
it is better to re-create the function, instead of debugging:
Code:
Public Function DateAddWorkdays( _
    ByVal lngNumber As Long, _
    ByVal datDate As Date) _
    As Date
    Dim subtrahend As Integer
   
If lngNumber < 0 Or lngNumber > 0 Then
    subtrahend = IIf(lngNumber > 0, 1, -1)
    While NotWorkday(datDate)
        datDate = DateAdd("d", subtrahend, datDate)
    Wend
    Do While lngNumber <> 0
        datDate = DateAdd("d", subtrahend, datDate)
        If NotWorkday(datDate) = False Then
            lngNumber = lngNumber + (subtrahend * (-1))
        End If
    Loop
Else
    While NotWorkday(datDate)
        datDate = DateAdd("d", 1, datDate)
    Wend
End If
DateAddWorkdays = datDate

End Function


Public Function NotWorkday(dteDate As Date) As Boolean
'strDate1 = Format(datDate, "\#yyyy\/mm\/dd\#")
NotWorkday = False
If Weekday(dteDate, vbMonday) > 5 Then
    NotWorkday = True
ElseIf DCount("1", "tblHoliday", "HolidayDate = #" & Format(dteDate, "mm/dd/yyyy") & "#") > 0 Then
    NotWorkday = True
End If
End Function

Thanks for this, I have tried this code but it is now not picking up any of the holidays. I tried different formats in the DCount but to no avail
 

arnelgp

error reading drive A:
Local time
Today, 21:51
Joined
May 7, 2009
Messages
11,130
change this to:
Code:
Public Function NotWorkday(dteDate As Date) As Boolean
'strDate1 = Format(datDate, "\#yyyy\/mm\/dd\#")
NotWorkday = False
If Weekday(dteDate, vbMonday) > 5 Then
    NotWorkday = True
ElseIf DCount("1", "tblHoliday", "DateValue(HolidayDate) = #" & Format(dteDate, "mm/dd/yyyy") & "#") > 0 Then
    NotWorkday = True
End If
End Function
 

Integrate

Registered User.
Local time
Tomorrow, 02:51
Joined
Oct 20, 2013
Messages
27
change this to:
Code:
Public Function NotWorkday(dteDate As Date) As Boolean
'strDate1 = Format(datDate, "\#yyyy\/mm\/dd\#")
NotWorkday = False
If Weekday(dteDate, vbMonday) > 5 Then
    NotWorkday = True
ElseIf DCount("1", "tblHoliday", "DateValue(HolidayDate) = #" & Format(dteDate, "mm/dd/yyyy") & "#") > 0 Then
    NotWorkday = True
End If
End Function
Perfect. Thank you! :)
 

Users who are viewing this thread

Top Bottom