|
VBA and Access do not provide any support for working with the typical
workdays (Monday through Friday).
VBA Developers Handbook (Sybex) contains several functions that provide
information about the next and previous workday, and finding the first and
last workday in a month. To deal with Holidays, the original SkipHolidays
function accepted a reference to a recordset containing all the dates that you
would want these functions to skip over.
To increase flexibility and ease of use, the original functions have been
re-written to accept an array of Holidays, much like Excel's WorkDay
function.
Public Function dhAddWorkDaysA(lngDays As Long, _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant) As Date
Dim lngCount As Long
Dim dtmTemp As Date
If dtmDate = 0 Then
dtmDate = Date
End If
dtmTemp = dtmDate
For lngCount = 1 To lngDays
dtmTemp = dhNextWorkdayA(dtmTemp, adtmDates)
Next lngCount
dhAddWorkDaysA = dtmTemp
End Function
Public Function dhNextWorkdayA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date
If dtmDate = 0 Then
dtmDate = Date
End If
dhNextWorkdayA = SkipHolidaysA(adtmDates, dtmDate + 1, 1)
End Function
Public Function dhPreviousWorkdayA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date
If dtmDate = 0 Then
dtmDate = Date
End If
dhPreviousWorkdayA = SkipHolidaysA(adtmDates, dtmDate - 1, -1)
End Function
Public Function dhFirstWorkdayInMonthA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date
Dim dtmTemp As Date
If dtmDate = 0 Then
dtmDate = Date
End If
dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate), 1)
dhFirstWorkdayInMonthA = SkipHolidaysA(adtmDates, dtmTemp, 1)
End Function
Public Function dhLastWorkdayInMonthA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date
Dim dtmTemp As Date
If dtmDate = 0 Then
dtmDate = Date
End If
dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)
dhLastWorkdayInMonthA = SkipHolidaysA(adtmDates, dtmTemp, -1)
End Function
Public Function dhCountWorkdaysA(ByVal dtmStart As Date, ByVal dtmEnd As Date, _
Optional adtmDates As Variant = Empty) _
As Integer
Dim intDays As Integer
Dim dtmTemp As Date
Dim intSubtract As Integer
>
If dtmEnd < dtmStart Then
dtmTemp = dtmStart
dtmStart = dtmEnd
dtmEnd = dtmTemp
End If
dtmStart = SkipHolidaysA(adtmDates, dtmStart, 1)
dtmEnd = SkipHolidaysA(adtmDates, dtmEnd, -1)
If dtmStart > dtmEnd Then
dhCountWorkdaysA = 0
Else
intDays = dtmEnd - dtmStart + 1
intSubtract = (DateDiff("ww", dtmStart, dtmEnd) * 2)
intSubtract = intSubtract + _
CountHolidaysA(adtmDates, dtmStart, dtmEnd)
dhCountWorkdaysA = intDays - intSubtract
End If
End Function
Private Function CountHolidaysA( _
adtmDates As Variant, _
dtmStart As Date, dtmEnd As Date) As Long
Dim lngItem As Long
Dim lngCount As Long
Dim blnFound As Long
Dim dtmTemp As Date
On Error GoTo HandleErr
lngCount = 0
Select Case VarType(adtmDates)
Case vbArray + vbDate, vbArray + vbVariant
For lngItem = LBound(adtmDates) To UBound(adtmDates)
dtmTemp = adtmDates(lngItem)
If dtmTemp >= dtmStart And dtmTemp <= dtmEnd Then
If Not IsWeekend(dtmTemp) Then
lngCount = lngCount + 1
End If
End If
Next lngItem
Case vbDate
If adtmDates >= dtmStart And adtmDates <= dtmEnd Then
If Not IsWeekend(adtmDates) Then
lngCount = 1
End If
End If
End Select
ExitHere:
CountHolidaysA = lngCount
Exit Function
HandleErr:
Resume ExitHere
End Function
Private Function FindItemInArray(varItemToFind As Variant, _
avarItemsToSearch As Variant) As Boolean
Dim lngItem As Long
On Error GoTo HandleErrors
For lngItem = LBound(avarItemsToSearch) To UBound(avarItemsToSearch)
If avarItemsToSearch(lngItem) = varItemToFind Then
FindItemInArray = True
GoTo ExitHere
End If
Next lngItem
ExitHere:
Exit Function
HandleErrors:
Resume ExitHere
End Function
Private Function IsWeekend(dtmTemp As Variant) As Boolean
If VarType(dtmTemp) = vbDate Then
Select Case Weekday(dtmTemp)
Case vbSaturday, vbSunday
IsWeekend = True
Case Else
IsWeekend = False
End Select
End If
End Function
Private Function SkipHolidaysA( _
adtmDates As Variant, _
dtmTemp As Date, intIncrement As Integer) As Date
Dim strCriteria As String
Dim strFieldName As String
Dim lngItem As Long
Dim blnFound As Boolean
On Error GoTo HandleErrors
Do
Do While IsWeekend(dtmTemp)
dtmTemp = dtmTemp + intIncrement
Loop
Select Case VarType(adtmDates)
Case vbArray + vbDate, vbArray + vbVariant
Do
blnFound = FindItemInArray(dtmTemp, adtmDates)
If blnFound Then
dtmTemp = dtmTemp + intIncrement
End If
Loop Until Not blnFound
Case vbDate
If dtmTemp = adtmDates Then
dtmTemp = dtmTemp + intIncrement
End If
End Select
Loop Until Not IsWeekend(dtmTemp)
ExitHere:
SkipHolidaysA = dtmTemp
Exit Function
HandleErrors:
Resume ExitHere
End Function
|
