You can use the code below to create the table and populate the records. You
will need to adjust the query at
Populate additional fields (Other than holiday fields) for the start of the
Fiscal year (6 sets my fiscal year start as July. I think you will need to
use 9 to get the Fiscal Year to start in April - you can play a bit with it
and see what works) Also, note that I am storing numbers and not text for
things like quarter.
Once you have copied and pasted the code into a new vba module, you can build
the calendar table with a simple statement in the immediate window.
sBuildCalendarTable #2007-01-01#,#2014-12-31#,False
OH, WATCH OUT for the newsreader breaking the code into multiple lines where
it should not. I try to make the lines short enough to avoid that, but I may
have missed something.
'===========================================================================
'=============================CODE Starts===================================
Option Compare Database
Option Explicit
Public Sub sBuildCalendarTable(dStartDate As Date, _
dEndDate As Date, _
Optional tfOptionalHolidays As Boolean = True)
Dim strSQL As String
Dim dbAny As DAO.Database
Set dbAny = DBEngine(0)(0)
'============================================================================
' Build the Calendar Table
'============================================================================
strSQL = "CREATE TABLE CalendarTable (" & _
" TheDate DateTime Constraint PKTheDate Primary Key" & _
", IsWeekDay YesNo " & _
", IsHoliday YesNo " & _
", HolidayName Text(50)" & _
", CalYear Short" & _
", CalYrQuarter Byte" & _
", CalYrWeekNumber Byte" & _
", FiscalYear Short" & _
", FYQuarter Byte" & _
", FYWeekNumber Byte" & _
", MonthNumber Byte" & _
", DayNumber Byte" & _
", DayOfWeek Byte" & _
", NthWeekDay Byte" & _
", DayName Text(9)" & _
")"
dbAny.Execute strSQL, dbFailOnError
strSQL = "CREATE INDEX ixCalYear ON CalendarTable (Calyear)"
dbAny.Execute strSQL, dbFailOnError
strSQL = "CREATE INDEX ixFiscalYear ON CalendarTable (FiscalYear)"
dbAny.Execute strSQL, dbFailOnError
sFillCalendarTable dStartDate, dEndDate
'============================================================================
' Populate additional fields (Other than holiday fields)
'============================================================================
strSQL = "UPDATE CalendarTable " & _
"SET CalendarTable.IsWeekday = Weekday([theDate]) In (2,3,4,5,6)" & _
", CalendarTable.CalYear = Year([TheDate])" & _
", CalendarTable.CalYrQuarter = DatePart(""q"",[TheDate])" & _
", CalendarTable.CalYrWeekNumber = DatePart(""ww"",[TheDate],3)" & _
", CalendarTable.FiscalYear = Year(DateAdd(""m"",6,[Thedate]))" & _
", CalendarTable.FYQuarter = " & _
"DatePart(""q"",DateAdd(""m"",6,[TheDate]))" & _
", CalendarTable.FYWeekNumber = " & _
"DatePart(""ww"",DateSerial(Year([TheDate]), " & _
"Month([TheDate])+6,Day([TheDate])),3)" & _
", CalendarTable.MonthNumber = Month([TheDate])" & _
", CalendarTable.DayNumber = Day([TheDate])" & _
", CalendarTable.DayOfWeek = Weekday([TheDate])" & _
", CalendarTable.NthWeekDay = (Day([TheDate])-1)\7+1;"
dbAny.Execute strSQL, dbFailOnError
'============================================================================
' Populate Holiday fields (USA)
'============================================================================
'CHRISTMAS
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Christmas"" " & vbCrLf & _
" WHERE (((CalendarTable.MonthNumber)=12) AND
((CalendarTable.DayNumber)=25));"
dbAny.Execute strSQL, dbFailOnError
'Columbus Day (Effective 1971 when Congress changed to Mondays)
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Columbus Day"" " & vbCrLf & _
" WHERE (((CalendarTable.MonthNumber)=10) " & _
" AND ((CalendarTable.DayOfWeek)=2) " & _
" AND ((CalendarTable.NthWeekDay)=2) " & _
" AND ((CalendarTable.CalYear)>=1971));"
dbAny.Execute strSQL, dbFailOnError
'Independence Day (July 4)
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Independence Day"" " & vbCrLf & _
" WHERE (((CalendarTable.MonthNumber)=7) " & _
" AND ((CalendarTable.DayNumber)=4));"
dbAny.Execute strSQL, dbFailOnError
'Labor Day
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Labor Day"" " & vbCrLf & _
" WHERE (((CalendarTable.MonthNumber)=9) " & _
" AND ((CalendarTable.DayOfWeek)=2) " & _
" AND ((CalendarTable.NthWeekDay)=1) " & _
" AND ((CalendarTable.CalYear)>=1894));"
dbAny.Execute strSQL, dbFailOnError
'Martin Luther King day
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Martin Luther King Day"" " & vbCrLf & _
" WHERE (((CalendarTable.MonthNumber)=1) " & _
" AND ((CalendarTable.DayOfWeek)=2) " & _
" AND ((CalendarTable.NthWeekDay)=3) " & _
" AND ((CalendarTable.CalYear)>=1983));"
dbAny.Execute strSQL, dbFailOnError
'Memorial Day
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Memorial Day"" " & vbCrLf & _
" WHERE (((CalendarTable.MonthNumber)=5) " & _
" AND ((CalendarTable.DayOfWeek)=2) " & _
" AND ((Exists (SELECT * FROM CalendarTable as Tmp " & _
" WHERE MonthNumber = 5 and DayOfWeek =2 " & _
"AND Tmp.CalYear = CalendarTable.CalYear " & _
" and Tmp.TheDate > CalendarTable.TheDate))=False) " & _
"AND ((CalendarTable.CalYear)>=1971));"
dbAny.Execute strSQL, dbFailOnError
'New Years Day
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""New Years"" " & vbCrLf & _
" WHERE (((CalendarTable.MonthNumber)=1) AND((CalendarTable.DayNumber)=1))"
dbAny.Execute strSQL, dbFailOnError
'Presidents Day (Washington's Birthday)
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Presidents Day"" " & vbCrLf & _
" WHERE (((CalendarTable.MonthNumber)=2) " & _
" AND ((CalendarTable.NthWeekDay)=3) " & _
" AND ((CalendarTable.DayOfWeek)=2) " & _
" AND ((CalendarTable.CalYear)>=1971));"
dbAny.Execute strSQL, dbFailOnError
'Thanksgiving Day
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Thanksgiving"" " & vbCrLf & _
" WHERE (((CalendarTable.MonthNumber)=11) " & _
" AND ((CalendarTable.DayOfWeek)=5) " & _
" AND ((CalendarTable.NthWeekDay)=4) " & _
" AND ((CalendarTable.CalYear)>=1863));"
dbAny.Execute strSQL, dbFailOnError
'Veteran's Day
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Veterans Day"" " & vbCrLf & _
" WHERE (((CalendarTable.MonthNumber)=11) " & _
" AND ((CalendarTable.DayNumber)=11) " & _
" AND ((CalendarTable.CalYear)>1977));"
dbAny.Execute strSQL, dbFailOnError
'----------------------------------------------------------------------------
' Set Observance day if Holiday falls on Saturday or Sunday
'----------------------------------------------------------------------------
'Observe on Friday
strSQL = "UPDATE CalendarTable AS C INNER JOIN CalendarTable AS T " & _
"ON C.TheDate = T.TheDate-1 " & _
" SET C.IsHoliday = True" & _
", C.HolidayName = T.HolidayName & "" (observed)"" " & vbCrLf & _
" WHERE T.IsHoliday=True and T.DayOfWeek=7;"
dbAny.Execute strSQL, dbFailOnError
'Observe on Monday
strSQL = "UPDATE CalendarTable AS C INNER JOIN CalendarTable AS T " & _
" ON C.TheDate = T.TheDate+1 " & _
" SET C.IsHoliday = True" & _
", C.HolidayName = T.HolidayName & "" (observed)"" " & vbCrLf & _
" WHERE T.IsHoliday=True " & _
" and T.DayOfWeek=1 " & _
" AND T.HolidayName Not Like ""Easter*"";"
dbAny.Execute strSQL, dbFailOnError
'----------------------------------------------------------------------------
' Easter Holiday
'----------------------------------------------------------------------------
strSQL = "UPDATE CalendarTable " & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Easter Day"" " & vbCrLf & _
" WHERE (((CalendarTable.DayOfWeek)=1) " & _
" AND ((CalendarTable.TheDate)=fCalcEaster([CalYear])) " & _
" AND ((CalendarTable.MonthNumber) In (3,4,5)));"
dbAny.Execute strSQL, dbFailOnError
If tfOptionalHolidays Then
'Easter Monday (Optional)
strSQL = _
"UPDATE CalendarTable INNER JOIN CalendarTable AS CalendarTable_1 " & _
" ON CalendarTable.TheDate = CalendarTable_1.TheDate+1 " & vbCrLf & _
" SET CalendarTable.IsHoliday = True," & _
" CalendarTable.HolidayName = ""Easter Monday"" " & vbCrLf & _
" WHERE CalendarTable_1.HolidayName=""Easter Day"""
dbAny.Execute strSQL, dbFailOnError
'Good Friday (Optional)
strSQL = "UPDATE CalendarTable INNER JOIN " & _
" CalendarTable AS CalendarTable_1 " & vbCrLf & _
" ON CalendarTable.TheDate = CalendarTable_1.TheDate-2 " & vbCrLf & _
" SET CalendarTable.IsHoliday = True" & _
", CalendarTable.HolidayName = ""Good Friday"" " & vbCrLf & _
" WHERE CalendarTable_1.HolidayName=""Easter Day"";"
dbAny.Execute strSQL, dbFailOnError
'Thanksgiving Friday (Optional)
strSQL = "UPDATE CalendarTable AS CalendarTable_1" & _
" INNER JOIN CalendarTable " & _
" ON CalendarTable_1.TheDate = CalendarTable.TheDate+1" & _
" SET CalendarTable_1.IsHoliday = True" & _
", CalendarTable_1.HolidayName = ""Thanksgiving Friday"" " & _
" WHERE CalendarTable.HolidayName = ""Thanksgiving"" " & _
" AND CalendarTable.DayOfWeek = 5"
dbAny.Execute strSQL, dbFailOnError
End If 'Optional Holidays
End Sub
Private Sub sFillCalendarTable(dStart, dEnd)
Dim rst As DAO.Recordset
Dim db As DAO.Database
Dim iCount As Long
On Error GoTo sFillCalendarTable_Error
Set db = CurrentDb()
Set rst = db.OpenRecordset("SELECT TheDate FROM CalendarTable WHERE
TheDate is Null")
With rst
For iCount = 0 To DateDiff("d", dStart, dEnd)
.AddNew
rst!TheDate = DateAdd("d", iCount, dStart)
.Update
Next iCount
End With
Exit Sub
sFillCalendarTable_Error:
Resume Next 'Assumption that error is caused by trying to add duplicate record
End Sub
Function fCalcEaster(Y As Long)
'===============================================================================
' Procedure : EasterHodges
' Created : 2/22/2008 15:48
' Last Update :
' Author : John Spencer
' Purpose : Calculate the date of Easter (US) from 1583 to 4099
' Arguments : Y = Year as a 4 digit Long
'===============================================================================
'by David Hodges, derived by refining the
'Butcher's Ecclesiastical Calendar rule
Dim A As Long, B As Long, C As Long, D As Long
Dim E As Long, F As Long, G As Long, H As Long
Dim J As Long, K As Long, M As Long, N As Long
Dim P As Long, Dy As Long, Mth As Long
' Validate argument
If Y < 1583 Or Y > 4099 Then
fCalcEaster = Null
fCalcEaster = False
' MsgBox "Hodges method only applies to the revised " & vbcrlf & _
"calculation in the Gregorian calendar from 1583 to 4099 AD"
Exit Function
End If
A = Y \ 100 'Century
B = Y Mod 100 'Year in Century
C = (3 * (A + 25)) \ 4
D = (3 * (A + 25)) Mod 4
E = (8 * (A + 11)) \ 25
F = (5 * A + B) Mod 19
G = (19 * F + C - E) Mod 30
H = (F + 11 * G) \ 319
J = (60 * (5 - D) + B) \ 4
K = (60 * (5 - D) + B) Mod 4
M = (2 * J - K - G + H) Mod 7
N = (G - H + M + 114) \ 31
P = (G - H + M + 114) Mod 31
Dy = P + 1
Mth = N
fCalcEaster = DateSerial(Y, Mth, Dy)
'Easter Sunday is g - h + m days after March 22nd
'(the earliest possible Easter date)
End Function
John Spencer
Access MVP 2002-2005, 2007-2010
The Hilltop Institute
University of Maryland Baltimore County
