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
