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

 

 

(Visited 191 times, 1 visits today)
Arzt für Allgemeinmedizin, multiple präventivmedizinische, schulmedizinische und komplementäre ZusatzausbildungenWissenschaftliche Arbeit und Forschungs-BeiträgeZahlreiche Artikel und VorträgeUmfangreiche Recherchen in der aktuellen medizinischen Forschung zum Zweck der Selbst-Weiterbildung und als Gedächtnis-Stütze.   Mässige Legasthenie, daher Rechtschreib- und Beistrichfehler, bitte nicht kommentieren, wer es nicht aushält bitte einfach nicht lesen - Dr. Retzek's Youtube - Kanal mit Testimonials usw. - neue Einträge abonnieren --> im Footer der Seite [toggle title="Ärztekammer Disclaimer"] Ärztekammmer Disclaimer die Oberösterreichische Ärztekammer moniert weite Teile diese Website als "aufdringlich, marktschreierisch und beim Laien den Eindruck medizinischer Exklusivität erweckend". Dies ist keinesfalls beabsichtigt, die Website ist ein absichtsloses Weiterbildungsmedium von Dr. Retzek, der seine wissenschaftlichen Pubmed-Recherchen hier mit ärztlichen Kollegen unentgeltlich teilt, wofür Dr. Retzek von vielen Kollegen aus dem In- und Ausland regelmässig Anerkennung ausgesprochen bekommt. Dass Wissenschaftsrecherchen und Studien "das Standesansehen der Ärzte" verletzen könnte, war Dr. Retzek nicht bewusst, er bedauert dies zutiefst und entschuldigt sich bei den betroffenen Kollegen. [/toggle] 

Kommentar gerne erwüscht wenn sie hilfreich für Leser sind

Diese Website verwendet Akismet, um Spam zu reduzieren. Erfahre mehr darüber, wie deine Kommentardaten verarbeitet werden.