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 Holiday is on working day. If it is on a saturday or sunday, it also substract it and produce a false result.
illustration of a false reading
A Function for Workdays:
Public Function Workdays(ByRef startDate As Date, ByRef endDate As Date, Optional ByRef strHolidays As String = "Holidays") As Integer
On Error GoTo Workdays_Error
Dim nWeekdays, nHolidays As Integer
Dim strWhere As String
startDate = DateValue(startDate)
endDate = DateValue(endDate)
nWeekdays = Weekdays(startDate, endDate)
If nWeekdays = -1 Then
Workdays = -1
GoTo Workdays_Exit
End If
strWhere = "[Holiday] >= #" & Format(startDate, "yyyy\/mm\/dd") & "# AND [Holiday] <= #" & Format(endDate, "yyyy\/mm\/dd") & "#"
nHolidays = DCount(Expr:="[Holiday]", Domain:=strHolidays, Criteria:=strWhere)
Workdays = nWeekdays - nHolidays
Workdays_Exit:
Exit Function
Resume Workdays_Exit
End Function
And here is a function for calculating weekdays:
Public Function Weekdays(ByRef startDate As Date, ByRef endDate As Date) As Integer
' Returns the number of weekdays in the period from startDate
' to endDate inclusive. Returns -1 if an error occurs.
On Error GoTo Weekdays_Error
Const ncNumberOfWeekendDays As Integer = 2 'The number of weekend days per week.
Dim varDays As Variant 'The number of days inclusive.
Dim varWeekendDays As Variant 'The number of weekend days.
Dim dtmX As Date 'Temporary storage for datetime.
' If the end date is earlier, swap the dates.
If endDate < startDate Then
dtmX = startDate
startDate = endDate
endDate = dtmX
End If
' Calculate the number of days inclusive (+ 1 is to add back startDate).
varDays = DateDiff(Interval:="d", date1:=startDate, date2:=endDate) + 1
' Calculate the number of weekend days.
varWeekendDays = (DateDiff(Interval:="ww", date1:=startDate, date2:=endDate) _
* ncNumberOfWeekendDays) + IIf(DatePart(Interval:="w", _
Date:=startDate) = vbSunday, 1, 0) + IIf(DatePart(Interval:="w", Date:=endDate) = vbSaturday, 1, 0)
' Calculate the number of weekdays.
Weekdays = (varDays - varWeekendDays)
Weekdays_Exit:
Exit Function
Weekdays_Error:
Weekdays = -1
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Weekdays"
Resume Weekdays_Exit
Please advise how to ignore holiday if holiday = 1 or holiday = 7.
Plus, in extended period of time, there could be more than one holidays, falling or not on weekend.
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.
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
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
