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

后端 未结 3 950
星月不相逢
星月不相逢 2021-01-27 06:17

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

3条回答
  •  隐瞒了意图╮
    2021-01-27 06:49

    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
    

提交回复
热议问题