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
Google-ZENSUR!
Google zensiert meine Homepage ganz ordentlich, es ist mir tw. selber nicht möglich Artikel von mir bei Google zu finden. Desswegen bitte zum Newsletter anmelden und diesen an Freunde oder per Facebook teilen sowie die Suchfunktion innerhalb meiner Website verwenden. Folgen sie mir auch auf Twitter, dort kündige ich wichtige Artikel auch an.