der Code ist an die 2 Jahre alt, scheint aber noch zu klappen
Option Explicit
Sub TestDate()
Dim myDay As Date
Debug.Print IsMoveableFeast("28.03.2016")
Debug.Print IsMoveableFeast("25.03.2016")
Debug.Print IsMoveableFeast("05.05.2016")
Debug.Print IsMoveableFeast("16.05.2016")
Debug.Print IsMoveableFeast("26.05.2016")
'Test
Debug.Print IsMoveableFeast("26.02.2016")
Debug.Print IsStaticFeast("01.01.2016")
Debug.Print IsStaticFeast("01.05.2016")
Debug.Print IsStaticFeast("25.12.2016")
Debug.Print IsStaticFeast("26.12.2016")
'Test
Debug.Print IsStaticFeast("26.02.2016")
Debug.Print IsBAYERNFeast("06.01.2016")
'Test
Debug.Print IsBAYERNFeast("26.02.2016")
'Sonderform Bus u. Bettag
Debug.Print IsBB("16.11.2016")
'Test
Debug.Print IsBB("26.02.2016")
End Sub
Private Function IsMoveableFeast(aktDatum) As Boolean
'bewegliche ab Ostersonntag
Dim oSonn As Date 'Ostersonntag
Dim bbTag As Date 'Buß u. Bettag
Dim myDate As Date, aYear As Integer
myDate = CDate(aktDatum): aYear = Year(myDate)
'berechne Ostersonntag
oSonn = _
WorksheetFunction.Round((CDate(Day(Minute(aYear / 38) / 2 + 55) + _
(IIf(Minute(aYear / 38) / 2 + 55 < 60, 1, 0)) & ".4." & aYear) / 7), 0) * 7 - 6
If oSonn = myDate Then IsMoveableFeast = True
If oSonn - 2 = myDate Then IsMoveableFeast = True
If oSonn + 1 = myDate Then IsMoveableFeast = True
If oSonn + 39 = myDate Then IsMoveableFeast = True
If oSonn + 50 = myDate Then IsMoveableFeast = True
If oSonn + 60 = myDate Then IsMoveableFeast = True
End Function
Private Function IsStaticFeast(aktDatum) As Boolean
Const cSTATIC As String = "01.01 01.05 03.10 25.12 26.12"
Dim arrStr() As String, varStr As Variant
Dim arrVar() As String
Dim myDate As Date, aYear As Integer
myDate = CDate(aktDatum): aYear = Year(myDate)
arrStr = Split(cSTATIC, " ")
For Each varStr In arrStr
arrVar = Split(varStr, ".")
If DateSerial(aYear, CInt(arrVar(1)), CInt(arrVar(0))) = myDate Then IsStaticFeast = True
Next varStr
End Function
Private Function IsBAYERNFeast(aktDatum) As Boolean
Const cSTATIC As String = "06.01 15.08 01.11"
Dim arrStr() As String, varStr As Variant
Dim arrVar() As String
Dim myDate As Date, aYear As Integer
myDate = CDate(aktDatum): aYear = Year(myDate)
arrStr = Split(cSTATIC, " ")
For Each varStr In arrStr
arrVar = Split(varStr, ".")
If DateSerial(aYear, CInt(arrVar(1)), CInt(arrVar(0))) = myDate Then IsBAYERNFeast = True
Next varStr
End Function
'Sonderform Buß u. Bettag
Private Function IsBB(aktDatum) As Boolean
Dim myDate As Date, aYear As Integer
Dim bbTag As Date 'Buß u. Bettag
myDate = CDate(aktDatum): aYear = Year(myDate)
bbTag = DateSerial(aYear, 12, 25) - _
Weekday(DateSerial(aYear, 12, 25), vbMonday) - 4 * 7 - vbWednesday
If bbTag = myDate Then IsBB = True
End Function
|