Calculate U.S. holidays for any given year

This piece of code was written -- just as a starting point -- to perhaps, at some point, add holidays to your server's holiday list. This code is for the U.S. only.

Option Public
Option Declare

Public Type Holiday
 Name As String
 Date As Variant
End Type

Sub Initialize

'See: http://www.vpcalendar.net/Holiday_Dates/Holiday_Determinations.html

 Dim holidays(17) As Holiday

 Dim tmpString As String
 Dim tmpDate As Variant
 Dim wkDay As Integer
 Dim holidayYear As Integer

 tmpString = Inputbox$("Enter year for 
list of USA holidays dates for 
that year")
 On Error Goto errHandler
 holidayYear = Cint(tmpString)
 tmpString = ""

 '===================================
 holidays(0).Name = "New Year's Day"
 'January 1 - Always
 tmpDate = Dateserial(holidayYear, 1, 1)
 holidays(0).Date = tmpDate
 '===================================

 '===================================
 holidays(1).Name = "Martin Luther King Jr Day"
 '3rd Monday in January - this means it can fall
 anywhere between Jan.
15 and Jan. 21
 tmpDate = Dateserial(holidayYear, 1, 15)
 wkDay = Weekday(tmpDate)
 holidays(1).Date = tmpDate - wkDay + 
2 'Subtract the current day, add 2
for Monday
 If wkDay > 2 Then
  holidays(1).Date = holidays(1).Date + 7 
'Add 7 to go to next
week
 End If
 '===================================

 '===================================
 holidays(2).Name = "Groundhog Day"
 'February 1 - Always
 tmpDate = Dateserial(holidayYear, 2, 2)
 holidays(2).Date = tmpDate
 '===================================

 '===================================
 holidays(3).Name = "Valentine's Day"
 'February 14 - Always
 tmpDate = Dateserial(holidayYear, 2, 14)
 holidays(3).Date = tmpDate
 '===================================

 '===================================
 holidays(4).Name = "President's Day"
 '3rd Monday in February - this means it can 
fall anywhere between Feb.
15 and Feb. 21
 tmpDate = Dateserial(holidayYear, 2, 15)
 wkDay = Weekday(tmpDate)
 holidays(4).Date = tmpDate - wkDay + 2 
'Subtract the current day, add 2
for Monday
 If wkDay > 2 Then
  holidays(4).Date = holidays(4).Date + 7 
'Add 7 to go to next
week
 End If
 '===================================

 '===================================
 holidays(5).Name = "St. Patrick's Day"
 'March 17 - Always
 tmpDate = Dateserial(holidayYear, 3, 17)
 holidays(5).Date = tmpDate
 '===================================

 '===================================
 holidays(7).Name = "Easter"
 holidays(7).Date = dateEaster(holidayYear)
 '===================================

 '===================================
 holidays(6).Name = "Good Friday"
 holidays(6).Date = holidays(7).Date - 2 
'Easter Sunday - 2 days for 
Good Friday
 '===================================

 '===================================
 holidays(8).Name = "Mother's Day"
 '2nd Sunday in May - this means it can fall 
anywhere between May 8 and 
May 14
 tmpDate = Dateserial(holidayYear, 5, 8)
 wkDay = Weekday(tmpDate)
 holidays(8).Date = tmpDate - wkDay + 1 
'Subtract the current day, add 1
for Sunday
 If wkDay > 1 Then
  holidays(8).Date = holidays(8).Date + 7 
'Add 7 to go to next
week
 End If
 '===================================

 '===================================
 holidays(9).Name = "Memorial Day"
 'Last Monday in May - this means it can fall 
anywhere between May 25 
and May 31
 tmpDate = Dateserial(holidayYear, 5, 25)
 wkDay = Weekday(tmpDate)
 holidays(9).Date = tmpDate - wkDay + 2 
'Subtract the current day, add 2
for Monday
 If wkDay > 2 Then
  holidays(9).Date = holidays(9).Date + 7 
'Add 7 to go to next 
week
 End If
 '===================================

 '===================================
 holidays(10).Name = "Father's Day"
 '3rd Sunday in June - this means it can fall 
anywhere between June 15 
and June 21
 tmpDate = Dateserial(holidayYear, 6, 15)
 wkDay = Weekday(tmpDate)
 holidays(10).Date = tmpDate - wkDay + 1 
'Subtract the current day, add 
1 for Sunday
 If wkDay > 1 Then
  holidays(10).Date = holidays(10).Date + 7
 'Add 7 to go to next
week
 End If
 '===================================

 '===================================
 holidays(11).Name = "Independence Day"
 'July 4 - Always
 tmpDate = Dateserial(holidayYear, 7, 4)
 holidays(11).Date = tmpDate
 '===================================

 '===================================
 holidays(12).Name = "Labor Day"
 '1st Monday in September - this means it can 
fall anywhere between
Sept. 1 and Sept. 7
 tmpDate = Dateserial(holidayYear, 9, 1)
 wkDay = Weekday(tmpDate)
 holidays(12).Date = tmpDate - wkDay + 2 
'Subtract the current day, add 
2 for Monday
 If wkDay > 2 Then
  holidays(12).Date = holidays(12).Date + 7
 'Add 7 to go to next
week
 End If
 '===================================

 '===================================
 holidays(13).Name = "Columbus Day"
 '2nd Monday in October - this means it can 
fall anywhere between Oct. 8 
and Oct. 14
 tmpDate = Dateserial(holidayYear, 10, 8)
 wkDay = Weekday(tmpDate)
 holidays(13).Date = tmpDate - wkDay + 2 
'Subtract the current day, add
2 for Monday
 If wkDay > 2 Then
  holidays(13).Date = holidays(13).Date + 7 
'Add 7 to go to next
week
 End If
 '===================================

 '===================================
 holidays(14).Name = "Halloween"
 'October 31 - Always
 tmpDate = Dateserial(holidayYear, 10, 31)
 holidays(14).Date = tmpDate
 '===================================

 '===================================
 holidays(15).Name = "Veteran's Day"
 'November 11 - Always
 tmpDate = Dateserial(holidayYear, 11, 11)
 holidays(15).Date = tmpDate
 '===================================

 '===================================
 holidays(16).Name = "Thanksgiving"
 '4th Thursday in November - this means it can
 fall anywhere between
Nov. 22 and Nov. 28
 tmpDate = Dateserial(holidayYear, 11, 22)
 wkDay = Weekday(tmpDate)
 holidays(16).Date = tmpDate - wkDay + 5 
'Subtract the current day, add
5 for Thursday
 If wkDay > 5 Then
  holidays(16).Date = holidays(16).Date + 7 
'Add 7 to go to next
week
 End If
 '===================================

 '===================================
 holidays(17).Name = "Christmas Day"
 'December 25 - Always
 tmpDate = Dateserial(holidayYear, 12, 25)
 holidays(17).Date = tmpDate
 '===================================

 Forall h In holidays
  tmpString = tmpString & Chr(13) & 
Format(h.Date, "yyyy.mm.dd")
& Chr(9) & h.Name
 End Forall

 Msgbox Mid$(tmpString, 2), , "USA Holidays for " 
& Cstr(holidayYear)

 Goto endFunc

errHandler:
 Msgbox "Invalid year entered"
 Resume endFunc

endFunc:
End Sub

Function dateEaster(y As Integer) As Variant

'See http://aa.usno.navy.mil/faq/docs/easter.html

 Dim c As Integer
 Dim n As Integer
 Dim k As Integer
 Dim i As Integer
 Dim j As Integer
 Dim l As Integer
 Dim m As Integer
 Dim d As Integer

c = y \ 100
n = y - 19 * ( y \ 19 )
k = ( c - 17 )  25
i = c - c \ 4 - ( c - k ) \ 3 +
 19 * n + 15
i = i - 30 * ( i \ 30 )
i = i - ( i \ 28 ) * ( 1 - ( i \ 28 ) 
* ( 29 \ ( i + 1 ) ) * 
( ( 21 - n ) \ 11 ) )
j = y + y  4 + i + 2 - c + c \ 4
j = j - 7 * ( j \ 7 )
l = i - j
m = 3 + ( l + 40 ) \ 44
d = l + 28 - 31 * ( m \ 4 )



 dateEaster = Dateserial(y, m, d)

End Function

Do you have comments on this tip? Let us know.

This tip was submitted to the SearchDomino.com tip exchange by member Cesar Mugnatto. Please let others know how useful it is via the rating scale below. Do you have a useful Notes/Domino tip or code to share? Submit it to our monthly tip contest and you could win a prize and a spot in our Hall of Fame.