MS ACCESS VBA, working days function incl. holiday when faling on weekend

Question

When deploying MSDN function for calculating working days, beside a problem with date formatting I found an issue with Holiday count.

Calculation is correct, but only if

Answer 1

You can use the function below to get the number of working days (excluding public holidays) between two dates.

It requires a table named tbHolidays with a single field named _Date which holds the public holidays.

Public Function WorkingDaysInDateRange(ByVal DateFrom As Date, _
                                       ByVal DateTo As Date, _
                                       Optional ByVal includeStartDate As Long = 0) As Long
    On Error GoTo ErrorTrap

    'Calculate the number of days
    Dim lngTotalDays As Long
        lngTotalDays = DateDiff("y", DateFrom, DateTo) + includeStartDate

    'Calculate the number of weekend days.
    Dim lngWeekendDays As Long
        lngWeekendDays = (DateDiff("ww", DateFrom, DateTo) * 2) + _
                          IIf(DatePart("w", DateFrom) = vbSunday, 1, 0) + _
                          IIf(DatePart("w", DateTo) = vbSaturday, 1, 0)

    'Get Non working days count from tbHolidays excluding weekends
    Dim lngHolidays As Long
        lngHolidays = DCount("[_Date]", "tbHolidays", _
                             StringFormat("[_Date] Between #{0}# AND #{1}# AND Weekday([_Date]) Not In ({2}, {3})", Format(DateFrom, "mm/dd/yyyy"), _
                                                                                                                    Format(DateTo, "mm/dd/yyyy"), _
                                                                                                                    vbSaturday, vbSunday))
    Dim lngWrkDays As Long
        lngWrkDays = lngTotalDays - (lngWeekendDays + lngHolidays)

    'Return
    WorkingDaysInDateRange = lngWrkDays

Leave:
    On Error GoTo 0
    Exit Function

ErrorTrap:
    MsgBox Err.Description, vbCritical
    Resume Leave
End Function

---

The helper StringFormat function:

Public Function StringFormat(ByVal Item As String, ParamArray args() As Variant) As String

    Dim idx As Long
    For idx = LBound(args) To UBound(args)
        Item = Replace(Item, "{" & idx & "}", args(idx))
    Next idx

    StringFormat = Item
End Function

Answer 2

without delving into your code, I'd suggest doing a count of holidays in your holiday table that fall on weekends and which also fall inside the range of days you are considering. Subtract that total from an (I presume) otherwise correctly calculated total and you should have the proper adjustment taking weekend holidays into account.

Answer 3

It is much simpler just to loop the dates and count:

Public Function DateDiffWorkdays( _
    ByVal datDate1 As Date, _
    ByVal datDate2 As Date, _
    Optional ByVal booWorkOnHolidays As Boolean) _
    As Long

'   Calculates the count of workdays between datDate1 and datDate2.
'   2014-10-03. Cactus Data ApS, CPH

    Dim aHolidays() As Date

    Dim lngDiff     As Long
    Dim lngSign     As Long
    Dim lngHoliday  As Long

    lngSign = Sgn(DateDiff("d", datDate1, datDate2))
    If lngSign <> 0 Then
        If booWorkOnHolidays = True Then
            ' Holidays are workdays.
        Else
            ' Retrieve array with holidays between datDate1 and datDate2.
            aHolidays = GetHolidays(datDate1, datDate2)
        End If

        Do Until DateDiff("d", datDate1, datDate2) = 0
            Select Case Weekday(datDate1)
                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 datDate1 and datDate2.
                        ElseIf DateDiff("d", datDate1, aHolidays(lngHoliday)) = 0 Then
                            ' This datDate1 hits a holiday.
                            ' Subtract one day before adding one after the loop.
                            lngDiff = lngDiff - lngSign
                            Exit For
                        End If
                    Next
                    On Error GoTo 0
                    lngDiff = lngDiff + lngSign
            End Select
            datDate1 = DateAdd("d", lngSign, datDate1)
        Loop
    End If

    DateDiffWorkdays = lngDiff

End Function

and the holidays 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)

        ' 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