Public Function CountWeeks(ByVal dteStartDate As Date, intDays As Integer)
On Error Goto Err_CountWeeks
Dim dteTemp As Date
dteTemp = dteStartDate
Do While intDays <> 0
Select Case WeekDay(dteTemp)
Case Is = 1, 7
' do nothing
Case Else
Select Case dteTemp
Case Is = DateSerial(Year(dteTemp), 1, 1), _
[b]DateSerial(Year(dteTemp), 1, 2), _[/b]
DateOfEaster(Year(dteTemp)) - 2, _
DateOfEaster(Year(dteTemp)) + 1, _
GetBankHoliday(DateSerial(Year(dteTemp), 5, 1)), _
GetBankHoliday(DateSerial(Year(dteTemp), 5, 25)), _
GetBankHoliday(DateSerial(Year(dteTemp), 8, 25)), _
DateSerial(Year(dteTemp), 12, 25), _
DateSerial(Year(dteTemp), 12, 26)
' do nothing
Case Else
intDays = intDays - 1
End Select
End Select
dteTemp = dteTemp + 1
Loop
CountWeeks = dteTemp - 1 ' remove 1 due to final of loop
Exit_CountWeeks:
Exit Function
Err_CountWeeks:
MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
Resume Exit_CountWeeks
End Function
Public Function DateOfEaster(ByVal intYear As Integer) As Date
On Error GoTo Err_DateOfEaster
Dim intDominical As Integer, intEpact As Integer, intQuote As Integer
intDominical = 225 - (11 * (intYear Mod 19))
' if the Dominical is greater than 50 then subtract multiples of 30 until the resulting
' new value of it is less than 51
If intDominical > 50 Then
While intDominical > 50
intDominical = intDominical - 30
Wend
End If
' if the Dominical is greater than 48 subtract 1 from it
If intDominical > 48 Then intDominical = intDominical - 1
intEpact = (intYear + Int(intYear / 4) + intDominical + 1) Mod 7
intQuote = intDominical + 7 - intEpact
' if the quote is less than 32 then Easter is in March
' if the quote is greater than 31 then the quote minus 31 is its date in April
If intQuote > 31 Then
DateOfEaster = DateSerial(intYear, 4, intQuote - 31)
Else
DateOfEaster = DateSerial(intYear, 3, intQuote)
End If
Exit_DateOfEaster:
Exit Function
Err_DateOfEaster:
MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
Resume Exit_DateOfEaster
End Function
Public Function GetBankHoliday(ByRef dteBankHoliday As Date) As Date
On Error Goto Err_GetBankHoliday
Dim intCounter As Integer
For intCounter = 0 To 6
If WeekDay(dteBankHoliday + intCounter) = 2 Then
dteBankHoliday = dteBankHoliday + intCounter
Exit For
End If
Next intCounter
GetBankHoliday = dteBankHoliday
Exit_GetBankHoliday:
Exit Function
Err_GetBankHoliday:
MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
Resume Exit_GetBankHoliday
End Function