Build a Table of Holidays

Any rigorous scheduling function requires that the application only schedule activities on a workday. The knowledgebase and many other applications require that a table be developed that contains all the holidays for a given period. My application required scheduling events many years in advance so I either needed to manually build the holidays table or build one programmatically. the following code will load a table called tblHolidays with the date, name, and day of a given set of holidays for a year. The supplementary functions allow a user to drive the main function to build holidays for an integer number of years starting with this year and also get the day of the holiday during the loading process.

There are three main types of searches to determine a holiday. 1) On a specific date or the Monday following,
2) On the x occurrence of a day in a given month, 3) on the last occurence of a day in a given month. You can therefore use the template snippets within the function BuildHolidayList to create the code for other holidays. There are sites on the internet that will provide the rules for determining various holidays.

My internet search for this capability failed so I developed this one. It would be relatively easy to add holidays or to tailor the function to allow a return of true/false if a given day was a holiday.

You would need to modify the error handling to conform to whatever functionality your applications use.

TSQL Script to create the table:
CREATE TABLE tblHolidays
(
ID int IDENTITY(1, 1),
HolidayDate datetime,
Name varchar(50),
Weekday varchar(9)
)

Public Type HolidayData
dtDate As Date
strName As String
strWeekday As String
End Type
Dim vHolidayInfo(8) As HolidayData

Public Function BuildHolidayList(BuildYear As Long)

Dim lngDay As Long
Dim intWeekday As Integer
Dim intMondayCount As Integer
Dim intThursdayCount As Integer
Dim dtDate As Date
Dim strSQL As String

On Error GoTo HandleErr

' Get New Year's Day Holiday
' 1/1 or following Monday
dtDate = CDate("1/1/" & CStr(BuildYear))
With vHolidayInfo(0)
.dtDate = GetMondayFollowing(dtDate)
.strName = "New Year's Day"
.strWeekday = GetWeekday(.dtDate)
End With

' Get MLK Holiday
' Third Monday in January
dtDate = CDate("1/1/" & CStr(BuildYear))
For lngDay = 0 To 30
intWeekday = Weekday(dtDate + lngDay)
If intWeekday = vbMonday Then
With vHolidayInfo(1)
.dtDate = dtDate + lngDay + 14
.strName = "Martin Luther King's Birthday"
.strWeekday = GetWeekday(.dtDate)
End With
Exit For
End If
Next lngDay

' Third Monday in February
dtDate = CDate("2/1/" & CStr(BuildYear))
For lngDay = 0 To 27
intWeekday = Weekday(dtDate + lngDay)
If intWeekday = vbMonday Then
With vHolidayInfo(2)
.dtDate = dtDate + lngDay + 14
.strName = "President's Day"
.strWeekday = GetWeekday(.dtDate)
End With
Exit For
End If
Next lngDay

' Last Monday in May
dtDate = CDate("5/1/" & CStr(BuildYear))
For lngDay = 0 To 31
intWeekday = Weekday(dtDate + lngDay)
If intWeekday = vbMonday Then
With vHolidayInfo(3)
.dtDate = dtDate + lngDay
.strName = "Memorial Day"
.strWeekday = GetWeekday(.dtDate)
End With
End If
Next lngDay

dtDate = CDate("7/4/" & CStr(BuildYear))
With vHolidayInfo(4)
.dtDate = GetMondayFollowing(dtDate)
.strName = "Independence Day"
.strWeekday = GetWeekday(.dtDate)
End With

' First Monday in September
dtDate = CDate("9/1/" & CStr(BuildYear))
For lngDay = 0 To 29
intWeekday = Weekday(dtDate + lngDay)
If intWeekday = vbMonday Then
With vHolidayInfo(5)
.dtDate = dtDate + lngDay
.strName = "Labor Day"
.strWeekday = GetWeekday(.dtDate)
End With
Exit For
End If
Next lngDay

' First Fourth Thursday in November
dtDate = CDate("11/1/" & CStr(BuildYear))
intThursdayCount = 0
For lngDay = 0 To 31
intWeekday = Weekday(dtDate + lngDay)
If intWeekday = vbThursday Then
intThursdayCount = intThursdayCount + 1
If intThursdayCount = 4 Then
With vHolidayInfo(6)
.dtDate = dtDate + lngDay
.strName = "Thanksgiving Day"
.strWeekday = GetWeekday(.dtDate)
End With
With vHolidayInfo(7)
.dtDate = dtDate + lngDay + 1
.strName = "Day-After Thanksgiving"
.strWeekday = GetWeekday(.dtDate)
End With
Exit For
End If
End If
Next lngDay

dtDate = CDate("12/25/" & CStr(BuildYear))
With vHolidayInfo(8)
.dtDate = GetMondayFollowing(dtDate)
.strName = "Christmas Day"
.strWeekday = GetWeekday(.dtDate)
End With

strSQL = "DELETE FROM tblHolidays WHERE YEAR(HolidayDate) IN (" & CLng(BuildYear) & ")"
DoCmd.RunSQL strSQL

For lngDay = 0 To 7
strSQL = "INSERT INTO tblHolidays (HolidayDate, Name, Weekday) " _
& "VALUES (CAST('" & CStr(vHolidayInfo(lngDay).dtDate) _
& "' As datetime), '" & vHolidayInfo(lngDay).strName & "', '" _
& vHolidayInfo(lngDay).strWeekday & "')"
DoCmd.RunSQL strSQL
Next lngDay

Exit_Proc:
Exit Function

HandleErr:
Select Case Err.Number
Case Else
Call ErrorLog("basSchedule_BuildHolidayList", Err)
End Select
Resume Exit_Proc
Resume

End Function

Public Function GetWeekday(dtDate As Date) As String

Dim strWeekday As String
Dim intWeekday As Integer
intWeekday = Weekday(dtDate)

On Error GoTo HandleErr

Select Case intWeekday
Case vbMonday
strWeekday = "Monday"
Case vbTuesday
strWeekday = "Tuesday"
Case vbWednesday
strWeekday = "Wednesday"
Case vbThursday
strWeekday = "Thursday"
Case vbFriday
strWeekday = "Friday"
Case vbSaturday
strWeekday = "Saturday"
Case vbSunday
strWeekday = "Sunday"
Case Else
strWeekday = "Unknown"
End Select
GetWeekday = strWeekday

Exit_Proc:
Exit Function

HandleErr:
Select Case Err.Number
Case Else
Call ErrorLog("basSchedule_GetWeekday", Err)
End Select
Resume Exit_Proc
Resume

End Function

Public Function BuildHolidayLists(lngYears As Long)

Dim lngYear As Long
lngYear = Year(Date)
For lngYears = 0 To lngYears - 1
Call BuildHolidayList(lngYear + lngYears)
Next lngYears

End Function

Public Function GetMondayFollowing(dtDate As Date) As Date

On Error GoTo HandleErr

'vbSaturday = 7
'vbSunday = 0
Dim intDayOfWeek

intDayOfWeek = Weekday(dtDate)
Select Case intDayOfWeek
Case vbMonday To vbFriday
GetMondayFollowing = dtDate
Case vbSaturday
GetMondayFollowing = dtDate + 2
Case vbSunday
GetMondayFollowing = dtDate + 1
End Select

Exit_Proc:
Exit Function

HandleErr:
Select Case Err.Number
Case Else
Call ErrorLog("basSchedule_GetMondayFollowing", Err)
End Select
Resume Exit_Proc
Resume
End Function