These are the functions that someone posted on here.I have a Holidays dbase & table. I run Workdays function.
I have a target completion date for a deivery and I need to record how many working days (exclude weekends and Bank hols) between the actual delivery and the target date. It should be +ve number if late or -ve if early.
The dhcountworkdays function called swaps the dates around if the first date is later than the second :
' Swap the dates if necessary.
If dtmEnd < dtmStart Then
dtmTemp = dtmStart
dtmStart = dtmEnd
dtmEnd = dtmTemp
End If
I don't know how to change this to suit my requirements.
Thanks Guy's
Option Compare Database
Option Explicit
Private Const m_cHolidaysDataBasePath As String = "C:\documents and settings\steve\Desktop\"
Private Const m_cHolidaysDataBaseName As String = "Holidays.MDB"
Public Const g_cUSHolidays As String = "BankHols09"
'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, "Fields")
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("bankhols09", _
DAO.dbOpenDynaset)
Debug.Print dhFirstWorkdayInMonth(#12/25/2009#, rst, "Date")
Debug.Print dhLastWorkdayInMonth(#12/25/2009#, rst, "Date")
Debug.Print dhNextWorkday(#4/9/2009#, rst, "Date")
Debug.Print dhNextWorkday(#12/25/2009#, rst, "Date")
Debug.Print dhPreviousWorkday(#12/25/2009#, rst, "Date")
Debug.Print dhPreviousWorkday(#12/25/2009#, 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("BankHols09", _
DAO.dbOpenDynaset)
Debug.Print dhCountWorkdays(#3/30/2003#, #4/3/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)
ExitHere:
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
