Feiertage in Excel (VBA)

Guten Morgen zusammen,
einmal mehr eine Frage, die mich beschäftigt.
Mit Hilfe der folgenden Routine gelingt es mir ganz gut, Feiertage innerhalb eines Kalenderjahres in einem gesonderten Tabellenblatt ("Feiertage") darzustellen.
Option Explicit

Sub Ostersonntag()
On Error Resume Next
Dim intjahr As Integer
Dim BegDatum, y As Date
Dim x As Integer
Application.ScreenUpdating = False
BegDatum = Worksheets("Zeitdaten").Range("A1")
Worksheets("Zeitdaten").Select
Range("A37").Value = Format(Year(BegDatum), "0000")
intjahr = Worksheets("Zeitdaten").Range("A37")
x = (((255 - 11 * (intjahr Mod 19)) - 21) Mod 30) + 21
y = DateSerial(intjahr, 3, 1) + x + (x > 48) + 6 - ((intjahr + intjahr \ 4 + x + (x > 48) + 1)  _
Mod 7)
Worksheets("Feiertage").Range("A1") = DateSerial(intjahr, 1, 1)
Worksheets("Feiertage").Range("A2") = y - 2
Worksheets("Feiertage").Range("A3") = y
Worksheets("Feiertage").Range("A4") = y + 1
Worksheets("Feiertage").Range("A5") = DateSerial(intjahr, 5, 1)
Worksheets("Feiertage").Range("A6") = y + 39
Worksheets("Feiertage").Range("A7") = y + 49
Worksheets("Feiertage").Range("A8") = y + 50
Worksheets("Feiertage").Range("A9") = y + 60
Worksheets("Feiertage").Range("A10") = DateSerial(intjahr, 10, 3)
Worksheets("Feiertage").Range("A11") = DateSerial(intjahr, 11, 1)
Worksheets("Feiertage").Range("A12") = DateSerial(intjahr, 12, 25)
Worksheets("Feiertage").Range("A13") = DateSerial(intjahr, 12, 26)
Worksheets("Feiertage").Range("A15") = y - 48
Worksheets("Feiertage").Range("A16") = DateSerial(intjahr, 12, 24)
Worksheets("Feiertage").Range("A17") = DateSerial(intjahr, 12, 31)
Worksheets("Feiertage").Range("B1") = "Neujahr"
Worksheets("Feiertage").Range("B2") = "Karfreitag"
Worksheets("Feiertage").Range("B3") = "Ostersonntag"
Worksheets("Feiertage").Range("B4") = "Ostermontag"
Worksheets("Feiertage").Range("B5") = "Maifeiertag"
Worksheets("Feiertage").Range("B6") = "Christi Himmelfahrt"
Worksheets("Feiertage").Range("B7") = "Pfingstsonntag"
Worksheets("Feiertage").Range("B8") = "Pfingstmontag"
Worksheets("Feiertage").Range("B9") = "Fronleichnam"
Worksheets("Feiertage").Range("B10") = "Tag der deutschen Einheit"
Worksheets("Feiertage").Range("B11") = "Allerheiligen"
Worksheets("Feiertage").Range("B12") = "1. Weihnachtstag"
Worksheets("Feiertage").Range("B13") = "2. Weihnachtstag"
Worksheets("Feiertage").Range("B15") = "Rosenmontag"
Worksheets("Feiertage").Range("B16") = "Heiligabend"
Worksheets("Feiertage").Range("B17") = "Sylvester"
Application.ScreenUpdating = True
End Sub

Mit Hilfe dieser Daten "vergleiche" ich nur innerhalb einer anderen Routine, ob denn ein Datum des aktuellen Monats (Zellen "A5:A35" des Arbeitsblattes "Abrechnung") mit einem dieser Daten im Blatt "Feiertage" identisch ist. Wenn ja, kopiere ich Daten aus Zellen "D5:D35" in "Z5:Z35".
Wie gesagt, so weit "passt" das.
Nur habe ich irgendwie den Eindruck, das diese Vorgehensweise vereinfacht werden kann/soll. Hierbei würde ich gerne auf dieses zusätzliche Tabellenblatt ("Feiertage") verzichten und den Vergleich, ob den Feiertage im aktuellen Monat anfallen, direkt im Modul erledigen. Wenn wirklich Feiertage anfallen, sollen denn die Daten aus "D5:D35" direkt in "Z5:Z35" kopiert werden.
Keine Ahnung, wie das gehen soll. Hat den wer von Euch dazu ne Idee? Einmal mehr nur via VBA
Besten Dank für Eure Überlegungen.
Gruß
Uwe

Hallo Luc,
die Function kann man natürlich auch in einer Sub-Routine aufrufen, wenn man's kann.
Gruß
Franz
Beispiel:

Sub Feiertag_einfuegen()
Dim Zeile As Long, x As Long, y As Long, wks As Worksheet
Set wks = ActiveSheet
With wks
'in Spalte A (1) stehen Datumsangaben, in Spalte B (2) wird Wochentags- _
kürzel oder Feiertag eingetragen
x = 10: y = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(x, 2), .Cells(y, 2)).ClearContents
For Zeile = x To y
'Zelle auf Datum prüfen
If IsDate(.Cells(Zeile, 1)) Then
'Prüfen ob Feiertag
If Feiertag(Datum:=.Cells(Zeile, 1).Value) = "" Then
'Wochentag einfügen
.Cells(Zeile, 2).Value = Format(.Cells(Zeile, 1), "ddd")
Else
'Feiertag einfügen
.Cells(Zeile, 2).Value = Feiertag(.Cells(Zeile, 1).Value)
End If
End If
Next
End With
End Sub

Und als Extra eine Funktion, die bundeslandspezifisch auf Feiertag prüft + ein paar Sondertage.

Function FeiertagDE(Datum As Date, Optional Bundesland As String, _
Optional bolKath As Boolean, Optional bolRosenmontag As Boolean, _
Optional bolDez24 As Boolean, Optional bolDez31 As Boolean, _
Optional bolAug08 As Boolean, Optional bolFronleichnam As Boolean) As String
'##Ersteller fcs, Datum: 2009-09-15
'Funktion ermittelt für das Datum, ob es auf einem Feiertag liegt und gibt den _
Feiertag zurück
'Option bolKatk - Marie Himmelfahrt für Bayern in überwiegend katholischen Gemeinden
'Option bolFronleichnam - für Sachsen und Thüringen gem spezieller Regelung
'Beispiel für Funktionsaufruf:
' strFeiertag = FeiertagDE(Datum:=.Cells(Zeile, 1).Value, Bundesland:="BY", bolKath:=True)
'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
'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
'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
'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
On Error GoTo Fehler
Dim intJahr As Integer, Tag As Long
Dim x As Integer, Ostern As Date
Dim intI As Integer, arrDatum(1 To 20)  As Date, arrText(1 To 20) As String
intJahr = VBA.Year(Datum)
'Ostertag ermitteln
x = (((255 - 11 * (intJahr Mod 19)) - 21) Mod 30) + 21
Ostern = DateSerial(intJahr, 3, 1) + x + (x > 48) + 6 - _
((intJahr + intJahr \ 4 + x + (x > 48) + 1) Mod 7)
'Feiertage Bundesweit
intI = 0
intI = intI + 1: arrDatum(intI) = DateSerial(intJahr, 1, 1): arrText(intI) = "Neujahr"
intI = intI + 1: arrDatum(intI) = Ostern - 2: arrText(intI) = "Karfreitag"
intI = intI + 1: arrDatum(intI) = Ostern: arrText(intI) = "Ostersonntag"
intI = intI + 1: arrDatum(intI) = Ostern + 1: arrText(intI) = "Ostermontag"
intI = intI + 1: arrDatum(intI) = DateSerial(intJahr, 5, 1): arrText(intI) = "Maifeiertag"
intI = intI + 1: arrDatum(intI) = Ostern + 39: arrText(intI) = "Christi Himmelfahrt"
intI = intI + 1: arrDatum(intI) = Ostern + 49:  arrText(intI) = "Pfingstsonntag"
intI = intI + 1: arrDatum(intI) = Ostern + 50: arrText(intI) = "Pfingstmontag"
intI = intI + 1
arrDatum(intI) = DateSerial(intJahr, 10, 3):  arrText(intI) = "Tag der deutschen Einheit"
intI = intI + 1
arrDatum(intI) = DateSerial(intJahr, 12, 25):  arrText(intI) = "1. Weihnachtstag"
intI = intI + 1
arrDatum(intI) = DateSerial(intJahr, 12, 26):  arrText(intI) = "2. Weihnachtstag"
'Feiertage in einzelnen Bundesländern
'Heilige 3 Könige (1.11.)
Select Case Bundesland
Case "BW", "BY", "SL"
intI = intI + 1
arrDatum(intI) = DateSerial(intJahr, 11, 1):  arrText(intI) = "Hl. 3 Könige"
End Select
'Fronleichnam
Select Case Bundesland
Case "BW", "BY", "HE", "NW", "RP", "SL"
intI = intI + 1
intI = intI + 1: arrDatum(intI) = Ostern + 60: arrText(intI) = "Fronleichnam"
Case "ST", "TH"
If bolFronleichnam = True Then
intI = intI + 1
intI = intI + 1: arrDatum(intI) = Ostern + 60: arrText(intI) = "Fronleichnam"
End If
End Select
'Marie Himmelfahrt (15.08.)
Select Case Bundesland
Case "SL"
intI = intI + 1
arrDatum(intI) = DateSerial(intJahr, 11, 1):  arrText(intI) = "Marie Himmelfahrt"
Case "BY"
If bolKath = True Then
intI = intI + 1
arrDatum(intI) = DateSerial(intJahr, 11, 1):  arrText(intI) = "Marie Himmelfahrt"
End If
End Select
'Allerheiligen (01.11.)
Select Case Bundesland
Case "BW", "BY", "NW", "RP", "SL", "SN"
intI = intI + 1
arrDatum(intI) = DateSerial(intJahr, 11, 1):  arrText(intI) = "Allerheiligen"
End Select
'Buß- und Bettag  (Mittwoch vor dem 23. November)
Select Case Bundesland
Case "SN"
intI = intI + 1
Tag = 22
Do Until VBA.Weekday(DateSerial(intJahr, 11, Tag)) = vbWednesday
Tag = Tag - 1
Loop
arrDatum(intI) = DateSerial(intJahr, 11, Tag):  arrText(intI) = "Buß und Bettag"
End Select
'Sonstige arbeitsfreie Tage /Feiertage
'Rosenmontag
If bolRosenmontag = True Then
intI = intI + 1
arrDatum(intI) = Ostern - 48:  arrText(intI) = "Rosenmontag"
End If
'8. August - Friedenstag Augsburg
If bolAug08 = True Then
intI = intI + 1
arrDatum(intI) = DateSerial(intJahr, 8, 8):    arrText(intI) = "Friedenstag"
End If
'24. Dezember (Heiligen Abend)
If bolDez24 = True Then
intI = intI + 1
arrDatum(intI) = DateSerial(intJahr, 12, 24):  arrText(intI) = "Heiligabend"
End If
'31. dezember (Sylvester)
If bolDez31 = True Then
intI = intI + 1
arrDatum(intI) = DateSerial(intJahr, 12, 31):  arrText(intI) = "Sylvester"
End If
'Eingabe-Datum prüfen
For intI = LBound(arrDatum) To intI
If Datum = arrDatum(intI) Then
FeiertagDE = arrText(intI)
Exit For
End If
Next
Err.Clear
Fehler:
With Err
If .Number  0 Then
FeiertagDE = "#Fehler!"
End If
End With
End Function

Forumthread: Feiertage in Excel (VBA)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial