subtract days without weekends or holidays

[Alex]

I have the following expression in a query:

CDate:dhSubtractWorkDaysA([LTW1],[MatDueDateCalc],[HolidayArray])

I've posted the module below that contains functions that subtract # of days
in [LTW1] from the date in [MatDueDateCalc], without counting Saturdays,
Sundays or holidays. I have a table called Holiday with one field called
HolidayDates. Currently, when my query runs, a parameter box appears where I
can either type a holiday date or click OK to not include any holidays. I'm
not sure how to make my HolidaysDate table an array so that when I run this
query, it will look at the list of dates in my HolidayDate table and not
subtract a date if it is in the HolidayDate table. Can anyone please tell me
how to do this. I'm a very basic VBA user and I'm sort of at a loss.

Thank you so much -


Function Code:

Option Compare Database

Public Function dhSubtractWorkDaysA(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 = dhPreviousWorkdayA(dtmTemp, adtmDates)
Next lngCount
dhSubtractWorkDaysA = 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)
' Missy
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

I have the following query. I'm trying to avoid getting #error messages in
some of the fields that should return as null. How can I rewrite this query
correctly?

Thanks so much

MCSOne:
IIf(nz([M_B]="A",dhSubtractWorkDaysA([LTA2],[SystemDoc],[HolidayArray]),IIf([M_B]="W",dhSubtractWorkDaysA([LTW3],[SystemDoc],[HolidayArray]),IIf([M_B]="P"
Or [M_B]="T",dhSubtractWorkDaysA([LTTP2],[POIssueDate],[HolidayArray]))),"")))

-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1

It looks like the function "dhSubtractWorkDaysA" is returning a NULL.
Change it so it will return zero, instead. Also, change it so when it
receives a NULL parameter it returns zero, 'cuz it can't calculate the
work days if it doesn't have both dates.

To simplify the above expression you could change the call parameters
like this (I spread it out so you can see it better. It is really one
line.):

dhSubtractWorkDaysA(
Switch(
[M_B]="A", [LTA2],
[M_B]="W", [LTW3],
[M_B] IN ("P","T"), [LLTP2]
),
IIf([M_B] NOT IN ("P","T"), [SystemDoc],[POIssueDate])
[HolidayArray]
)

--
MGFoster:::mgf00 <at> earthlink <decimal-point> net
Oakland, CA (USA)

-----BEGIN PGP SIGNATURE-----
Version: PGP for Personal Privacy 5.0
Charset: noconv

iQA/AwUBQjIM2YechKqOuFEgEQISZgCcD/BL4Bz/NIGhxxL9haQCBleWcrYAoLmI
CKWoRY8cQUvRimYpSnkSDc46
=Kl7t
-----END PGP SIGNATURE-----

Expand AllCollapse All

 

[Peter Martin]

Alex,

I think you're making this more difficult than it is.
What you need is at http://www.mvps.org/access/datetime/date0006.htm

I can also suggest that if your holiday query is working fine, why not just
insert the weekends into the holiday table as well? Use a single way to
calculating working days. You would write a generator to insert the weekends
- this could be pure SQL. Since the holiday list must be updated by someone,
the weekends could be generated at the same time. This will work even if you
upsize to SQL server, and would be more adaptable (to other cultures, for
instance). And fast!

Note that the vba in the link requires a loop, which isn't necessary.
Suppose your 'date from' was a Monday. Then the count of successive days
and non-weekends will be
DOW M T W Th F S Su M T W Th F S S M T
DATE 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ...
DAYS 0 1 2 3 4 5 5 5 6 7 8 9 10 10 10 11 ....

In words, every 6th and 7th day we want to subtract 1 day each. In VBA this
is i - (i\7) - (i+1)\7
where \ is integer division, similar to int(i/7).

Note I'm counting midnight to midnight - the same starting and ending date
will be zero days. Friday midnight to Sat midnight will be one workday, as
will to Mon midnight. The above sequence defines a scale. For two DATES you
can subtract the DAYS value get the workdays between them. Date 0 is
31/12/1899 and a Sat, or 5 in the sequence, so

Private Function WorkdaysScale(dt As Date) As Long
Dim i As Long
i = dt + 5
WorkdaysScale = i - i \ 7 - (i + 1) \ 7
End Function

Public Function WorkDays(dtStart As Date, dtEnd As Date) As Long
'validate args here
WorkDays = WorkdaysScale(dtEnd) - WorkdaysScale(dtStart)
End Function

That should be a bit faster than the loop method!

Peter.