ExcelBanter - TODAY'S DATE PLUS "BUSINESS" DAYS

Business days is tricky... Here is a module that I use for business days. You
need a database of Holdays to go with this...

Option Explicit

Private Const m_cHolidaysDataBasePath As String = "D:/"
Private Const m_cHolidaysDataBaseName As String = "Holidays.MDB"
Public Const g_cUSHolidays As String = "tblUS"
Public Const g_cCdnHolidays As String = "tblCanada"

Public Function WorkDays(ByVal dteStartDate As Date, ByVal dteEndDate As
Date, _
ByVal strTableName As String) As Integer
Dim rst As DAO.Recordset
Dim db As DAO.Database

Set db = DAO.DBEngine.OpenDatabase(m_cHolidaysDataBasePath &
m_cHolidaysDataBaseName)
Set rst = db.OpenRecordset(strTableName, DAO.dbOpenDynaset)

WorkDays = dhCountWorkdays(dteStartDate, dteEndDate, rst, "Date")

End Function

Private Sub TestSkipHolidays()
Dim rst As DAO.Recordset
Dim db As DAO.Database
Set db = DAO.DBEngine.OpenDatabase(m_cHolidaysDataBasePath &
m_cHolidaysDataBaseName)
Set rst = db.OpenRecordset("tblHolidays", _
DAO.dbOpenDynaset)
Debug.Print dhFirstWorkdayInMonth(#12/25/2003#, rst, "Date")
Debug.Print dhLastWorkdayInMonth(#12/25/2003#, rst, "Date")
Debug.Print dhNextWorkday(#12/25/2003#, rst, "Date")
Debug.Print dhNextWorkday(#12/25/2003#, rst, "Date")
Debug.Print dhPreviousWorkday(#12/25/2003#, rst, "Date")
Debug.Print dhPreviousWorkday(#12/25/2003#, rst, "Date")
End Sub

Private Sub TestCountWorkdays()
Dim rst As DAO.Recordset
Dim db As DAO.Database
Set db = DAO.DBEngine.OpenDatabase(m_cHolidaysDataBasePath &
m_cHolidaysDataBaseName)
Set rst = db.OpenRecordset("tblHolidays", _
DAO.dbOpenDynaset)
Debug.Print dhCountWorkdays(#12/1/2003#, #12/31/2003#, _
rst, "Date")
Debug.Print dhCountWorkdays(#12/1/2003#, #12/31/2003#)

End Sub

Private Function SkipHolidays(rst As Recordset, _
strField As String, dtmTemp As Date, intIncrement As Integer) _
As Date
' Skip weekend days, and holidays in the
' recordset referred to by rst.
Dim strCriteria As String
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
If Left(strField, 1) < "[" Then
strField = "[" & strField & "]"
End If
Do
strCriteria = strField & _
" = #" & Format(dtmTemp, "mm/dd/yy") & "#"
rst.FindFirst strCriteria
If Not rst.NoMatch Then
dtmTemp = dtmTemp + intIncrement
End If
Loop Until rst.NoMatch
End If
End If
Loop Until Not IsWeekend(dtmTemp)
ExitHe
SkipHolidays = dtmTemp
Exit Function

HandleErr:
' No matter what the error, just
' return without complaining.
' The worst that could happen is that the code
' includes a holiday as a real day, even if
' it's in the table.
Resume ExitHere
End Function

'Function dhFirstWorkdayInMonth(Optional dtmDate As Date = 0, _
' Optional rst As Recordset = Nothing, _
' Optional strField As String = "") As Date
' ' Return the first working day in the month specified.
' Dim dtmTemp As Date
' Dim strCriteria As String
' If dtmDate = 0 Then
' ' Did the caller pass in a date? If not, use
' ' the current date.
' dtmDate = Date
' End If
' dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate), 1)
' dhFirstWorkdayInMonth = SkipHolidays(rst, strField, _
' dtmTemp, 1)
'End Function

Public Function dhLastWorkdayInMonth(Optional dtmDate As Date = 0, _
Optional rst As Recordset = Nothing, _
Optional strField As String = "") As Date
' Return the last working day in the month specified.
Dim dtmTemp As Date
Dim strCriteria As String
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)
dhLastWorkdayInMonth = SkipHolidays(rst, strField, _
dtmTemp, -1)
End Function

Public Function dhFirstWorkdayInMonth(Optional dtmDate As Date = 0, _
Optional rst As Recordset = Nothing, _
Optional strField As String = "") As Date
' Return the first working day in the month specified.
Dim dtmTemp As Date
Dim strCriteria As String
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate), 1)
dhFirstWorkdayInMonth = SkipHolidays(rst, strField, _
dtmTemp, 1)
End Function

Private Function dhCountWorkdays(ByVal dtmStart As Date, _
ByVal dtmEnd As Date, _
Optional rst As Recordset = Nothing, _
Optional strField As String = "") _
As Integer
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 = 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 (since 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 you have two weekend days.
intSubtract = (DateDiff("ww", dtmStart, dtmEnd) * 2)
' The answer, finally, 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(dtmStart, dtmEnd, rst, _
strField)

' intSubtract = intSubtract + 0
dhCountWorkdays = intDays - intSubtract
End If
End Function

Private Function CountHolidays(ByVal dtmStart As Date, _
ByVal dtmEnd As Date, _
Optional rst As Recordset = Nothing, _
Optional strField As String = "") _
As Integer

Dim intDays As Integer
Dim dtmTemp As Date
Dim intReturnValue As Integer

' Swap the dates if necessary.
If dtmEnd < dtmStart Then
dtmTemp = dtmStart
dtmStart = dtmEnd
dtmEnd = dtmTemp
End If

If Not rst Is Nothing Then
rst.MoveFirst

Do While Not rst.EOF
If rst.Fields(1) = dtmStart And rst.Fields(1) <= dtmEnd Then
intReturnValue = intReturnValue + 1
End If
rst.MoveNext
Loop
End If
CountHolidays = intReturnValue
End Function

Public 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

Public Function dhNextWorkday(Optional dtmDate As Date = 0, _
Optional rst As Recordset = Nothing, _
Optional strField As String = "") As Date
' Return the next working day after the specified date.
Dim dtmTemp As Date
Dim strCriteria As String
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhNextWorkday = SkipHolidays(rst, strField, dtmDate + 1, 1)
End Function

Public Function dhPreviousWorkday(Optional dtmDate As Date = 0, _
Optional rst As Recordset = Nothing, _
Optional strField As String = "") As Date
Dim dtmTemp As Date
Dim strCriteria As String
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhPreviousWorkday = SkipHolidays(rst, strField, _
dtmDate - 1, -1)
End Function

"Lisa" wrote:

How do I calculate todays date plus say, 90 "business" days?