' devHandbook
' count the numbers of workdays between two dates
' modified version (arnelgp)
Public Function dhCountWorkdays( _
ByVal dtmStart As Date, ByVal dtmend As Date, _
Optional holidayTable As String = "", _
Optional strField As String = "") _
As Integer
' Count the business days (not counting weekends/holidays) in
' a given date range.
Dim intDays As Integer
Dim dtmTemp As Date
Dim intSubtract As Integer
Dim rst As DAO.recordSet
' Swap the dates if necessary.
If dtmend < dtmStart Then
dtmTemp = dtmStart
dtmStart = dtmend
dtmend = dtmTemp
End If
If Len(holidayTable) Then
Set rst = CurrentDb.OpenRecordset(holidayTable, dbOpenSnapshot, ReadOnly)
End If
' Get the start and end dates to be weekdays.
dtmStart = SkipHolidays(rst, strField, dtmStart, 1)
dtmend = SkipHolidays(rst, strField, dtmend, -1)
If dtmStart > dtmend Then
' Sorry, no Workdays to be had. Just return 0.
dhCountWorkdays = 0
Else
intDays = dtmend - dtmStart + 1
' Subtract off weekend days. Do this by figuring out how
' many calendar weeks there are between the dates, and
' multiplying the difference by two (because there are two
' weekend days for each week). That is, if the difference
' is 0, the two days are in the same week. If the
' difference is 1, then we have two weekend days.
intSubtract = (DateDiff("ww", dtmStart, dtmend) * 2)
' The answer to our quest is all the weekdays, minus any
' holidays found in the table.
' If rst is Nothing, this call won't subtract any dates.
intSubtract = intSubtract + _
CountHolidays(rst, strField, dtmStart, dtmend)
dhCountWorkdays = intDays - intSubtract
End If
Set rst = Nothing
End Function
Private Function CountHolidays(rst As DAO.recordSet, strField As String, dtmStart As Date, dtmend As Date) As Integer
Dim bolNext As Boolean
Dim cnt As Integer
If (rst Is Nothing) Then
Exit Function
End If
With rst
If Not (.BOF And .EOF) Then
.MoveFirst
Do Until .NoMatch
If bolNext Then
.FindNext "[" & strField & "] >= " & Format(dtmStart, "\#mm\/dd\/yyyy\#") & " and " & _
"[" & strField & "] <= " & Format(dtmend, "\#mm\/dd\/yyyy\#")
Else
.FindFirst "[" & strField & "] >= " & Format(dtmStart, "\#mm\/dd\/yyyy\#") & " and " & _
"[" & strField & "] <= " & Format(dtmend, "\#mm\/dd\/yyyy\#")
End If
If Not .NoMatch Then
cnt = cnt + 1
End If
Loop
End If
End With
End Function
Private Function SkipHolidays( _
rst As DAO.recordSet, strField As String, _
dtmTemp As Date, intIncrement As Integer) As Date
' modified by arnelgp
' dao.recordset
'
' Skip weekend days, and holidays in the recordset
' referred to by rst.
' Return dtmTemp + as many days as it takes to get to
' a day that's not
' a holiday or weekend.
Dim strCriteria As String
Dim strFieldName As String
Dim bolNext As Boolean
On Error GoTo HandleErr
' Move up to the first Monday/last Friday, if the first/last
' of the month was a weekend date. Then skip holidays.
' Repeat this entire process until you get to a weekday.
' Unless rst contains a row for every day in the year (!)
' this should finally converge on a weekday.
Do
Do While IsWeekend(dtmTemp)
dtmTemp = dtmTemp + intIncrement
Loop
If Not rst Is Nothing Then
If Len(strField) > 0 Then
strFieldName = strField
If left$(strField, 1) <> "[" Then
strFieldName = "[" & strFieldName & "]"
End If
rst.MoveFirst
strCriteria = strFieldName & " = " & _
"#" & Format(dtmTemp, "mm/dd/yyyy") & "#"
Do
If bolNext Then
rst.FindNext strCriteria
Else
rst.FindFirst strCriteria
End If
If Not rst.NoMatch Then
bolNext = True
dtmTemp = dtmTemp + intIncrement
End If
Loop Until rst.NoMatch
End If
End If
Loop Until Not IsWeekend(dtmTemp)
ExitHere:
SkipHolidays = dtmTemp
Exit Function
HandleErr:
' No matter what the error, just
' return without complaining.
' The worst that could happen is that we
' include a holiday as a real day, even if
' it's in the table.
Resume ExitHere
End Function
' is Weekend?
Private Function IsWeekend(dtmTemp As Date) As Boolean
' If your weekends aren't Saturday (day 7)
' and Sunday (day 1), change this routine
' to return True for whatever days
' you DO treat as weekend days.
Select Case Weekday(dtmTemp)
Case vbSaturday, vbSunday
IsWeekend = True
Case Else
IsWeekend = False
End Select
End Function
