AW: VBA Termine mit Feiertagsverschiebung
21.07.2020 15:13:25
matze
Hallo Bernd,
was Du suchst scheint mir wie der Tourenplan unseres Abfallentsorgers auszusehen ;).
https://www.kaev.de/Templates/Content/DetailTourenplanWebsite/PDF/Jahreskalender.aspx?Ort=Calau&OrtId=10,24,0,0
Aber mal Spaß beiseite:
hier mal der Code für eine Feiertagsfunktion als Macro in ein Modul und Abfrage in Excel in irgendeine Zelle mit =Feiertag(datum)
Public Function Feiertag(Datum As Date) As String
On Error Resume Next
Dim jahr As Integer 'Jahr
Dim z As Integer 'Zähler für Anzahl Feiertage
Dim y As Date 'Ostersonntag
Dim arrDatum(1 To 60) As Date 'Datumsfeld der Feiertage
Dim arrText(1 To 60) As String 'Feld der Feiertagsbezeichnungen
Dim Besonde(1 To 60) As String 'Feld der Besonderheiten
'Abkürzungen für Bundesland
'BW=Baden-Württemberg NI=Niedersachsen
'BY=Bayern NW=Nordrhein -Westfalen
'BE=Berlin RP=Rheinland -Pfalz
'BB=Brandenburg SL=Saarland
'HB=Bremen SN=Sachsen
'HH=Hamburg ST=Sachsen -Anhalt
'HE=Hessen SH=Schleswig -Holstein
'MV=Mecklenburg -Vorpommern TH=Thüringen
'Feiertage BW BY BE BB HB HH HE MV NI NW RP SL SN ST SH TH
'Neujahrstag (01.01.) x x x x x x x x x x x x x x x x
'Hl. Drei Könige (06.01.) x x x
'Intern. Frauentag (08.03.) x
'Karfreitag x x x x x x x x x x x x x x x x
'Ostermontag x x x x x x x x x x x x x x x x
'Tag der Arbeit (01.05.) x x x x x x x x x x x x x x x x
'Christi Himmelfahrt x x x x x x x x x x x x x x x x
'Pfingstmontag x x x x x x x x x x x x x x x x
'Fronleichnam x x x x x x 1 1
'Friedensfest (08.08. nur Stadtkreis Augsburg)
'Mariä Himmelfahrt (15.08.) k x
'Tag der dt. Einheit (03.10.) x x x x x x x x x x x x x x x x
'Weltkindertag (20.09.) x
'Reformationstag (31.10.) x x x x x
'Allerheiligen (01.11.) x x x x x
'Buß- u. Bettag x
'1.Weihnachtstag (25.12.) x x x x x x x x x x x x x x x x
'2. Weihnachtstag (26.12) x x x x x x x x x x x x x x x x
'x bedeutet gesetzlicher Feiertag
'k bedeutet gesetzlicher Feiertag in Gemeinden mit überwiegend katholischer _
Bevölkerung
'1 Sonderregelungen in SN und TH
' Weltkindertag: nur Thüringen 20.9.
'aktuelles Jahr ermitteln
jahr = VBA.Year(Datum)
y = Ostern(jahr)
'Beginn der Feiertagsabfrage
'bewegliche Feiertage
z = 0
z = z + 1: arrDatum(z) = y - 52: arrText(z) = "Weiberfastnacht": Besonde(z) = " (kein _
_
_
_
Feiertag!)"
z = z + 1: arrDatum(z) = y - 48: arrText(z) = "Rosenmontag": Besonde(z) = " (kein _
_
_
_
Feiertag!)"
z = z + 1: arrDatum(z) = y - 47: arrText(z) = "Faschingsdienstag": Besonde(z) = " (kein _
_
_
_
Feiertag!)"
z = z + 1: arrDatum(z) = y - 46: arrText(z) = "Aschermittwoch": Besonde(z) = " (kein _
_
_
_
Feiertag!)"
z = z + 1: arrDatum(z) = y - 7: arrText(z) = "Palmsonntag": Besonde(z) = " (kein _
_
_
_
Feiertag!)"
z = z + 1: arrDatum(z) = y - 3: arrText(z) = "Gründonnerstag": Besonde(z) = " (kein _
_
_
_
Feiertag!)"
z = z + 1: arrDatum(z) = y - 2: arrText(z) = "Karfreitag": Besonde(z) = " ( _
bundesweit)"
z = z + 1: arrDatum(z) = y: arrText(z) = "Ostersonntag": Besonde(z) = " ( _
bundesweit: aber nur in Bbg. auch Feiertag)"
z = z + 1: arrDatum(z) = y + 1: arrText(z) = "Ostermontag": Besonde(z) = " ( _
bundesweit)"
z = z + 1: arrDatum(z) = y + 39: arrText(z) = "Christi Himmelfahrt": Besonde(z) = " ( _
bundesweit)"
z = z + 1: arrDatum(z) = y + 49: arrText(z) = "Pfingstsonntag": Besonde(z) = " ( _
bundesweit: aber nur in Bbg. auch Feiertag)"
z = z + 1: arrDatum(z) = y + 50: arrText(z) = "Pfingstmontag": Besonde(z) = " ( _
bundesweit)"
z = z + 1: arrDatum(z) = y + 60: arrText(z) = "Fronleichnam": Besonde(z) = " (nur _
_
_
_
Bay.,Ba-Wü.,Hessen,)"
z = z + 1: arrDatum(z) = Erntetag(jahr): arrText(z) = "Erntedankfest": Besonde(z) = " ( _
_
_
_
kein Feiertag! = 1.Sonntag im Oktober)"
z = z + 1: arrDatum(z) = Muttertag(jahr): arrText(z) = "Muttertag": Besonde(z) = " ( _
_
_
_
kein Feiertag! = 2.Sonntag im Mai)"
z = z + 1: arrDatum(z) = Advent(jahr): arrText(z) = "4.Advent": Besonde(z) = " ( _
_
_
_
kein Feiertag! = letzter Sonntag vor 25.12.)"
z = z + 1: arrDatum(z) = Advent(jahr) - 7: arrText(z) = "3.Advent": Besonde(z) = " ( _
_
_
_
kein Feiertag!)"
z = z + 1: arrDatum(z) = Advent(jahr) - 14: arrText(z) = "2.Advent": Besonde(z) = " ( _
_
_
_
kein Feiertag!)"
z = z + 1: arrDatum(z) = Advent(jahr) - 21: arrText(z) = "1.Advent": Besonde(z) = " ( _
_
_
_
kein Feiertag!)"
z = z + 1: arrDatum(z) = Advent(jahr) - 28: arrText(z) = "Totensonntag": Besonde(z) = " ( _
_
_
_
kein Feiertag!)"
z = z + 1: arrDatum(z) = Advent(jahr) - 32: arrText(z) = "Buß- und Bettag": Besonde(z) = " ( _
_
_
_
Feiertag nur in Sachsen)"
z = z + 1: arrDatum(z) = Advent(jahr) - 35: arrText(z) = "Volkstrauertag": Besonde(z) = " ( _
_
_
_
kein Feiertag!)"
z = z + 1: arrDatum(z) = Sommerzeit(jahr) 'Sommerzeit: letzter So im März
arrText(z) = "Beginn Sommerzeit": Besonde(z) = " (Zeitumstellung 1 Stunde vor)"
z = z + 1: arrDatum(z) = Sommerzeit(jahr) + 210 'Winterzeit: letzter So im Oktober
arrText(z) = "Ende Sommerzeit": Besonde(z) = " (Zeitumstellung 1 Stunde zurück)"
'unbewegliche Feiertage
z = z + 1: arrDatum(z) = DateSerial(jahr, 1, 1)
arrText(z) = "Neujahr": Besonde(z) = " (bundesweit)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 1, 6)
arrText(z) = "Hl. Drei Könige": Besonde(z) = " (nur Bay.,Ba-Wü.,Sa-Anhalt)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 2, 14)
arrText(z) = "Valentinstag": Besonde(z) = " (kein Feiertag!)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 3, 8)
arrText(z) = "Internationaler Frauentag": Besonde(z) = " (nur Berlin)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 4, 30)
arrText(z) = " Walpurgisnacht": Besonde(z) = " (kein Feiertag!)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 5, 1)
arrText(z) = "Tag der Arbeit": Besonde(z) = " (bundesweit)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 5, 8)
arrText(z) = "Tag der Befreiung vom Nationalsozialismus": Besonde(z) = " (nur Berlin 2020)"
' z = z + 1: arrDatum(z) = DateSerial(jahr, 6, 1)
' arrText(z) = "Internationaler Kindertag": Besonde(z) = " (kein Feiertag!)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 6, 17)
arrText(z) = "Tag der deutschen Einheit (17.Juni 1953)": Besonde(z) = " (kein Feiertag!)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 6, 20)
arrText(z) = "Fronleichnam": Besonde(z) = " (Ba-Wü., Bay., Hessen, NRW, Rheinland-Pfalz, _
_
_
_
Saarland)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 8, 8)
arrText(z) = "Friedensfest": Besonde(z) = " (nur Stadtkreis Augsburg)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 8, 15)
arrText(z) = "Mariä Himmelfahrt": Besonde(z) = " (Saarland, Bay. mit überwiegend kath. _
_
_
_
Bevölkerung)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 9, 20)
arrText(z) = "Weltkindertag": Besonde(z) = " (nur Thür.)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 10, 3)
arrText(z) = "Tag der Deutschen Einheit": Besonde(z) = " (bundesweit)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 10, 31)
arrText(z) = "Reformationstag"
Besonde(z) = " (Bbg Bremen Hamburg Mecklenburg-Vorpommern Niedersachsen Sachsen Sachsen- _
Anhalt Schleswig-Holstein Thüringen)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 11, 1)
arrText(z) = "Allerheiligen": Besonde(z) = " (BaWü Bay. NW RPf SL)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 12, 24)
arrText(z) = "Heiligabend": Besonde(z) = " (kein Feiertag!)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 12, 25)
arrText(z) = "1. Weihnachtsfeiertag": Besonde(z) = " (bundesweit)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 12, 26)
arrText(z) = "2. Weihnachtsfeiertag": Besonde(z) = " (bundesweit)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 12, 31)
arrText(z) = "Silvester": Besonde(z) = " (kein Feiertag!)"
z = z + 1: arrDatum(z) = DateSerial(jahr, 6, 27)
arrText(z) = "Siebenschläfer": Besonde(z) = " "
z = z + 1: arrDatum(z) = DateSerial(jahr, 3, 20)
arrText(z) = "Frühlingsanfang": Besonde(z) = " "
z = z + 1: arrDatum(z) = DateSerial(jahr, 6, 21)
arrText(z) = "Sommeranfang": Besonde(z) = " "
z = z + 1: arrDatum(z) = DateSerial(jahr, 9, 22)
arrText(z) = "Herbstanfang": Besonde(z) = " "
z = z + 1: arrDatum(z) = DateSerial(jahr, 12, 21)
arrText(z) = "Winteranfang": Besonde(z) = " "
z = z + 1: arrDatum(z) = DateSerial(jahr, 12, 6)
arrText(z) = "Nikolaustag": Besonde(z) = " "
z = z + 1: arrDatum(z) = DateSerial(jahr, 11, 2)
arrText(z) = "Allerseelen": Besonde(z) = " "
z = z + 1: arrDatum(z) = DateSerial(jahr, 11, 11)
arrText(z) = "Martinstag": Besonde(z) = " "
For z = LBound(arrDatum) To z
If Datum = arrDatum(z) Then
Feiertag = arrText(z) & Besonde(z)
End If
Next
End Function 'Feiertag
Function Ostern(jahr As Integer) As Date
'Ostersonntag nach Gauß'scher Osterformel berechnen
Dim x As Integer
x = (((255 - 11 * (jahr Mod 19)) - 21) Mod 30) + 21
Ostern = DateSerial(jahr, 3, 1) + x + (x > 48) + 6 - ((jahr + jahr \ 4 + x + (x > 48) + 1) _
_
_
_
Mod 7)
End Function
Function Erntetag(Ernte As Integer) As Date
'Erntedankfest = 1.Sonntag im Oktober
Dim x As Date
x = DateSerial(Ernte, 10, 1)
Do While DatePart("w", x, vbMonday)
Anschließend noch die Funktion für die korrekte DIN-Kalenderwoche:
Function KW_DIN(Datum)
KW_DIN = DatePart("ww", Datum, vbMonday, vbFirstFourDays)
End Function
Wenn man diese Funktionen über einen Sheet mit Kalender laufen läßt, braucht man die entsprechenden Datumswerte nur noch einfärben.