Feiertagsfunktion und Dienstplankalender – VBA

Holiday function and Weekend function in VBA for MS ACCESS – Eastern as list up 2050 as „Eastern-Function“ hard encoded

Österreichische Feiertags- und Wochend-Funktion, damit bekommt man einen Kalender aller Samstag/Sonntag inkl. aller österreichischen Feiertage bis 2050, man müsste nur die Ostern-Funktion erweitern um darüber hinaus Kalender zu erzeugen.

Function CreateSourceKalender(Startdatum As Date, Enddatum As Date, Tbl_Name As String)
Dim s As String, i As Long, j As Long, k As Long, d As Date, ss As String
Dim rssource As Recordset
Dim rsNew As Recordset
On Error GoTo x
ss = Tbl_Name
DoCmd.DeleteObject acTable, ss ‚abfangen des errors weiter unten
Call Copy_Table(„DP_Source“, ss, , True)
Set rsNew = CurrentDb.OpenRecordset(„select * from [“ + ss + „]“)
’s = Str(FürJahr) + „-1-1“
‚Startdatum = CDate(s)
’s = Str(FürJahr + 1) + „-1-1“
‚Enddatum = CDate(s) – 1
j = Startdatum
k = Enddatum
Do While Not j > k
s = IsFeiertag(CDate(j))
If (s <> „“) Or (Weekday(j) = 7) Or (Weekday(j) = 1) Then
i = i + 1
‚ Debug.Print IIf(s <> „“, „-„, „“) + s + “ “ + Format(CDate(j), „ddd, dd.mm.yyyy“)
rsNew.AddNew
rsNew!ID = i
rsNew!Tag = j
rsNew!TagText = IIf(s <> „“, „-„, „“) + s + “ “ + Format(CDate(j), „ddd, dd.mm.yyyy“)
If s <> „“ Then
rsNew![Sa/So/FT] = „FT“
Else
rsNew![Sa/So/FT] = IIf(Weekday(j) = 7, „Sa“, „So“)
End If
rsNew.Update
End If
j = j + 1
Loop
‚Debug.Print j – startdatum + “ Dien
MsgBox „neuen Dienstplan zwischen “ + Format(Startdatum, „dd. mmmm yyyy“) + “ und “ + Format(Enddatum, „dd. mmmm yyyy“) + “ erzeugt mit “ + CStr(i) + “ Dienst-Tagen in die Tabelle “ + Tbl_Name
Exit Function

x:
If Err.Number = 7874 Then Resume Next ‚delete Table error not found
MsgBox str(Err.Number) + “ “ + Err.Description + “ in funciton createsourcekalender“

End Function

Function IsFeiertag(d As Date) As String
On Error GoTo x
Dim da As Long, mo As Long, y As Long, Ostern As Date
da = day(d) ‚zum debuggen
mo = month(d)
y = year(d)

If day(d) = 1 And month(d) = 1 Then
IsFeiertag = „Neujahr“
Exit Function
End If

If day(d) = 6 And month(d) = 1 Then
IsFeiertag = „Hlg 3 Könige“
Exit Function
End If

Ostern = OsternImJahr(year(d))

If d + 1 = Ostern Then
IsFeiertag = „OsterSamstag“
Exit Function
End If

If d = Ostern Then
IsFeiertag = „Ostersonntag“
Exit Function
End If

If d – 1 = Ostern Then
IsFeiertag = „Ostermontag“
Exit Function
End If

If d – 39 = Ostern Then
IsFeiertag = „Christi Himmelfahrt (Do)“
Exit Function
End If

If d – 48 = Ostern Then
IsFeiertag = „Pfingst Samstag“
Exit Function
End If

If d – 49 = Ostern Then
IsFeiertag = „Pfingst-Sonntag“
Exit Function
End If

If d – 50 = Ostern Then
IsFeiertag = „Pfingst-Montag“
Exit Function
End If

If d – 60 = Ostern Then
IsFeiertag = „Fronleichnam“
Exit Function
End If

If day(d) = 1 And month(d) = 5 Then
IsFeiertag = „1.Mai“
Exit Function
End If

If day(d) = 15 And month(d) = 8 Then
IsFeiertag = „Mariä Himmelfahrt“
Exit Function
End If

If day(d) = 26 And month(d) = 10 Then
IsFeiertag = „Nationalfeiertag“
Exit Function
End If

If day(d) = 1 And month(d) = 11 Then
IsFeiertag = „Allerheiligen“
Exit Function
End If

If day(d) = 8 And month(d) = 12 Then
IsFeiertag = „Mariä Empfängnis“
Exit Function
End If

If day(d) = 24 And month(d) = 12 Then
IsFeiertag = „Weihnachten“
Exit Function
End If

If day(d) = 25 And month(d) = 12 Then
IsFeiertag = „Christtag“
Exit Function
End If

If day(d) = 26 And month(d) = 12 Then
IsFeiertag = „Stefanitag“
Exit Function
End If

If day(d) = 31 And month(d) = 12 Then
IsFeiertag = „Sylvester“
Exit Function
End If
Exit Function
x:
IsFeiertag = „“
End Function

Function String2Date(s As String) As Date
Dim d As String, m As String, y As String

End Function

‚weil berechnung für mich nicht möglich einfach händisch eingetragen
Function OsternImJahr(Jahr As Long) As Date ‚liefert das datum von Ostern im Jahr ….
Dim s As String, d As Date

Select Case Jahr ‚http://www.maa.mhn.de/StarDate/feiertage.html
Case 2015: s = „2015-4-5“
Case 2016: s = „2016-3-27“
Case 2017: s = „2017-4-16“
Case 2018: s = „2018-4-1“
Case 2019: s = „2019-4-21“
Case 2020: s = „2020-4-12“
Case 2021: s = „2021-4-4“
Case 2022: s = „2022-4-17“
Case 2023: s = „2023-4-9“
Case 2024: s = „2024-3-31“
Case 2025: s = „2025-4-20“
Case 2026: s = „2026-4-5“
Case 2027: s = „2027-3-28“
Case 2028: s = „2028-4-16“
Case 2029: s = „2029-4-1“
Case 2030: s = „2030-4-21“
Case 2031: s = „2031-4-13“
Case 2032: s = „2032-3-28“
Case 2033: s = „2033-4-17“
Case 2034: s = „2034-4-9“
Case 2035: s = „2035-3-25“
Case 2036: s = „2036-4-13“
Case 2037: s = „2037-4-5“
Case 2038: s = „2038-4-25“
Case 2039: s = „2039-4-10“
Case 2040: s = „2040-4-1“
Case 2041: s = „2041-4-21“
Case 2042: s = „2042-4-6“
Case 2043: s = „2043-3-29“
Case 2044: s = „2044-4-17“
Case 2045: s = „2045-4-9“
Case 2046: s = „2046-3-25“
Case 2047: s = „2047-4-14“
Case 2048: s = „2048-4-5“
Case 2049: s = „2049-4-18“
Case 2050: s = „2050-4-10“
Case 2051: s = „2051-4-2“
Case 2052: s = „2052-4-21“
Case 2053: s = „2053-4-6“
Case 2054: s = „2054-3-29“
Case 2055: s = „2055-4-18“
End Select

OsternImJahr = CDate(s)

End Function

Function CreateDPFürJahr(FürJahr As Long)
Dim s As String, ss As String
s = „1-1-“ + CStr(FürJahr)
ss = „31-12-“ + CStr(2050)
Call CreateSourceKalender(CDate(s), CDate(ss), „DP_für_“ + CStr(FürJahr))
End Function