Code:
Option Compare Database
Option Explicit
Public Function datNextWorkDate(datReferenceDate As Date, intDays As Integer) As Date
datNextWorkDate = DLookup("[Calendar Date]", "[qryWorkDaysDESC]", "[Calendar Date] <= #" & (datReferenceDate - intDays) & "#")
End Function
Public Function vcAddBusinessDaysWithHolidayDESC(datStart As Date, lDays As Long) As Date
Dim rHoliday As DAO.Recordset, vHolidays()
Set rHoliday = CurrentDb.OpenRecordset("qryHolidaysDESC")
vHolidays = rHoliday.GetRows(rHoliday.RecordCount)
Set rHoliday = Nothing
vcAddBusinessDaysWithHolidayDESC = dhSubtractWorkDaysA(lDays, datStart, vHolidays)
End Function
Function usbNetWorkdays(StartDate As Date, EndDate As Date) As Double
Dim retval As Double
If StartDate > EndDate Then
Do While EndDate <= StartDate
If WeekDay(EndDate) = 1 Or WeekDay(EndDate) = 7 Then
EndDate = EndDate + 1
Else
retval = retval + 1
EndDate = EndDate + 1
End If
Loop
Else
Do While StartDate <= EndDate
If WeekDay(StartDate) = 1 Or WeekDay(StartDate) = 7 Then
StartDate = StartDate + 1
Else
retval = retval + 1
StartDate = StartDate + 1
End If
Loop
End If
If retval = 0 Then
retval = 1
End If
usbNetWorkdays = retval - 1
End Function
Function dhFirstDayInWeek(Optional dtmDate As Date = 0) As Date
' Returns the first day in the week specified
' by the date in dtmDate.
' Uses localized settings for the first day of the week.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhFirstDayInWeek = dtmDate - WeekDay(dtmDate, _
vbUseSystem) + 1
End Function
Function dhLastDayInWeek(Optional dtmDate As Date = 0) As Date
' Returns the last day in the week specified by
' the date in dtmDate.
' Uses localized settings for the first day of the week.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhLastDayInWeek = dtmDate - WeekDay(dtmDate, vbUseSystem) + 7
End Function
Public Function YearStart(WhichYear As Integer) As Date
'It returns the first Monday of the specified year
Dim WeekDay As Integer
Dim NewYear As Date
NewYear = DateSerial(WhichYear, 1, 1)
WeekDay = (NewYear - 2) Mod 7 'Generate weekday index where Monday = 0
If WeekDay < 4 Then
YearStart = NewYear - WeekDay
Else
YearStart = NewYear - WeekDay + 7
End If
End Function
Public Function WeekStart(WhichWeek As Integer, WhichYear As _
Integer) As Date
'It returns the first Monday of the specified week
WeekStart = YearStart(WhichYear) + ((WhichWeek - 1) * 7)
End Function
Public Function NthDayOfWeek(Y As Integer, M As Integer, _
n As Integer, DOW As Integer) As Date
NthDayOfWeek = DateSerial(Y, M, (8 - WeekDay(DateSerial(Y, M, 1), _
(DOW + 1) Mod 8)) + ((n - 1) * 7))
End Function
Public Function SpecificWeekday(ByVal D As Date, Optional _
ByVal WhatDay As VbDayOfWeek = vbSaturday, _
Optional GetNext As Boolean = True) As Date
SpecificWeekday = (((D - WhatDay + GetNext) \ 7) - GetNext) * 7 + WhatDay
End Function
Function FirstOfNextMonth(datDATE As Date) As Date
Dim dtm As Date
dtm = datDATE
FirstOfNextMonth = DateSerial(Year(dtm), Month(dtm) + 1, 1)
End Function
Function FirstOfThisMonth(datDATE As Date) As Date
Dim dtm As Date
dtm = datDATE
FirstOfThisMonth = DateSerial(Year(dtm), Month(dtm), 1)
End Function
Function LastOfNextMonth(datDATE As Date) As Date
LastOfNextMonth = DateAdd("m", 1, FirstOfNextMonth(datDATE)) - 1
End Function
Function LastOfThisMonth(datDATE As Date) As Date
LastOfThisMonth = DateAdd("d", -1, FirstOfNextMonth(datDATE))
End Function
Public Function dhSubtractWorkDaysA(lngDays As Long, _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant) As Date
'modified by Vlad to subtract dates
' Add the specified number of work days to the
' specified date.
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
' In:
' lngDays:
' Number of work days to add to the start date.
' dtmDate:
' date on which to start looking.
' Use the current date, if none was specified.
' adtmDates (Optional):
' Array containing holiday dates. Can also be a single
' date value, if that's what you want.
' Out:
' Return Value:
' The date of the working day lngDays from the start, taking
' into account weekends and holidays.
' Example:
' dhAddWorkDaysA(10, #2/9/2000#, Array(#2/16/2000#, #2/17/2000#))
' returns #2/25/2000#, which is the date 10 work days
' after 2/9/2000, if you treat 2/16 and 2/17 as holidays
' (just made-up holidays, for example purposes only).
' Did the caller pass in a date? If not, use
' the current 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 = dhPreviousWorkdayA(dtmTemp, adtmDates)
Next lngCount
dhSubtractWorkDaysA = dtmTemp
End Function
Public Function dhAddWorkDaysA(lngDays As Long, _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant) As Date
' Add the specified number of work days to the
' specified date.
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
' In:
' lngDays:
' Number of work days to add to the start date.
' dtmDate:
' date on which to start looking.
' Use the current date, if none was specified.
' adtmDates (Optional):
' Array containing holiday dates. Can also be a single
' date value, if that's what you want.
' Out:
' Return Value:
' The date of the working day lngDays from the start, taking
' into account weekends and holidays.
' Example:
' dhAddWorkDaysA(10, #2/9/2000#, Array(#2/16/2000#, #2/17/2000#))
' returns #2/25/2000#, which is the date 10 work days
' after 2/9/2000, if you treat 2/16 and 2/17 as holidays
' (just made-up holidays, for example purposes only).
' Did the caller pass in a date? If not, use
' the current 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
' Return the next working day after the specified date.
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
' Requires:
' SkipHolidays
' IsWeekend
' In:
' dtmDate:
' date on which to start looking.
' Use the current date, if none was specified.
' adtmDates (Optional):
' Array containing holiday dates. Can also be a single
' date value.
' Out:
' Return Value:
' The date of the next working day, taking
' into account weekends and holidays.
' Example:
' ' Find the next working date after 5/30/97
' dtmDate = dhNextWorkdayA(#5/23/1997#, #5/26/97#)
' ' dtmDate should be 5/27/97, because 5/26/97 is Memorial day.
' Did the caller pass in a date? If not, use
' the current 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
' Return the previous working day before the specified date.
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
' Requires:
' SkipHolidays
' IsWeekend
' In:
' dtmDate:
' date on which to start looking.
' Use the current date, if none was specified.
' adtmDates (Optional):
' Array containing holiday dates. Can also be a single
' date value.
' Out:
' Return Value:
' The date of the previous working day, taking
' into account weekends and holidays.
' Example:
' ' Find the next working date before 1/1/2000
' dtmDate = dhPreviousWorkdayA(#1/1/2000#, Array(#12/31/1999#, #1/1/2000#))
' ' dtmDate should be 12/30/1999, because of the New Year's holidays.
' Did the caller pass in a date? If not, use
' the current 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
' Return the first working day in the month specified.
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
' Requires:
' SkipHolidays
' IsWeekend
' In:
' dtmDate:
' date within the month of interest.
' Use the current date, if none was specified.
' adtmDates (Optional):
' Array containing holiday dates. Can also be a single
' date value.
' Out:
' Return Value:
' The date of the first working day in the month, taking
' into account weekends and holidays.
' Example:
' ' Find the first working day in 1999
' dtmDate = dhFirstWorkdayInMonthA(#1/1/1999#, #1/1/1999#)
Dim dtmTemp As Date
' Did the caller pass in a date? If not, use
' the current 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
' Return the last working day in the month specified.
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
' Requires:
' SkipHolidays
' IsWeekend
' In:
' dtmDate:
' date within the month of interest.
' Use the current date, if none was specified.
' adtmDates (Optional):
' Array containing holiday dates. Can also be a single
' date value.
' Out:
' Return Value:
' The date of the last working day in the month, taking
' into account weekends and holidays.
' Example:
' ' Find the last working day in 1999
' dtmDate = dhLastWorkdayInMonthA(#12/1/1999#, #12/31/1999#)
Dim dtmTemp As Date
' Did the caller pass in a date? If not, use
' the current 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
' Count the business days (not counting weekends/holidays) in
' a given date range.
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
' Requires:
' SkipHolidays
' CountHolidays
' IsWeekend
' In:
' dtmStart:
' Date specifying the start of the range (inclusive)
' dtmEnd:
' Date specifying the end of the range (inclusive)
' (dates will be swapped if out of order)
' adtmDates (Optional):
' Array containing holiday dates. Can also be a single
' date value.
' Out:
' Return Value:
' Number of working days (not counting weekends and optionally, holidays)
' in the specified range.
' Example:
' Debug.Print dhCountWorkdaysA(#7/2/2000#, #7/5/2000#, _
' Array(#1/1/2000#, #7/4/2000#))
'
' returns 2, because 7/2/2000 is Sunday, 7/4/2000 is a holiday,
' leaving 7/3 and 7/5 as workdays.
Dim intDays As Integer
Dim dtmTemp As Date
Dim intSubtract As Integer
' Swap the dates if necessary.>
If dtmEnd < dtmStart Then
dtmTemp = dtmStart
dtmStart = dtmEnd
dtmEnd = dtmTemp
End If
' Get the start and end dates to be weekdays.
dtmStart = SkipHolidaysA(adtmDates, dtmStart, 1)
dtmEnd = SkipHolidaysA(adtmDates, dtmEnd, -1)
If dtmStart > dtmEnd Then
' Sorry, no Workdays to be had. Just return 0.
dhCountWorkdaysA = 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.
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
' Count holidays between two end dates.
'
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
' Required by:
' dhCountWorkdays
' Requires:
' IsWeekend
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
' You got an array of variants, or of dates.
' Loop through, looking for non-weekend values
' between the two endpoints.
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
' You got one date. So see if it's a non-weekend
' date between the two endpoints.
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:
' No matter what the error, just
' return without complaining.
' The worst that could happen is that the code
' include a holiday as a real day, even if
' it's in the table.
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:
' Do nothing at all.
' Return False.
Resume ExitHere
End Function
Private Function IsWeekend(dtmTemp As Variant) 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.
' Modified from code in "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
' Required by:
' SkipHolidays
' dhFirstWorkdayInMonth
' dbLastWorkdayInMonth
' dhNextWorkday
' dhPreviousWorkday
' dhCountWorkdays
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
' Skip weekend days, and holidays in the array referred to by adtmDates.
' Return dtmTemp + as many days as it takes to get to a day that's not
' a holiday or weekend.
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
' Required by:
' dhFirstWorkdayInMonthA
' dbLastWorkdayInMonthA
' dhNextWorkdayA
' dhPreviousWorkdayA
' dhCountWorkdaysA
' Requires:
' IsWeekend
Dim strCriteria As String
Dim strFieldName As String
Dim lngItem As Long
Dim blnFound As Boolean
On Error GoTo HandleErrors
' 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 adtmDates an item for every day in the year (!)
' this should finally converge on a weekday.
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:
' 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 array.
Resume ExitHere
End Function
' ********* Code End **************
Cheers,