AW: Monatsliste, Sonntage und Feiertage löschen
25.10.2005 16:17:03
UweD
Hallo
hab was gebastelt (Neu) und 2 Funktionen (Feiertage und Osterformel) aus unbekannter Quelle übernommen
seih dir das mal an.
Sub Neu()
Dim Anz%, Sp%, Z%, Jahr%, I%, Letzter%, J%, Datum As Date, TB, Test$
Anz = 12
Sp = 1 ' Spalte für Datum
Jahr = InputBox("Welches Jahr", "Eingaben Jahreszahl", Year(Date) + 1)
If (Jahr > 1904) And (Jahr < 2100) Then
For I = 1 To Anz
Set TB = Sheets(Format(I, "00"))
Z = 2
TB.Cells.Clear 'löscht die Inhalte vom Blatt
Letzter = Day(DateSerial(Jahr, I + 1, 0)) 'Letzter Tag des Monats
For J = 1 To Letzter
Datum = DateSerial(Jahr, I, J)
If Weekday(Datum, vbMonday) <= 5 Then
Test = FeierTag(Datum)
If Test = "" Then
TB.Cells(Z, Sp).Value = Format(Datum, "DDDD DD. MMMM YYYY")
Z = Z + 1
End If
End If
Next J
TB.Cells(Z + 2, Sp).Value = "Gesamtsumme"
Next
Else
MsgBox "Fehlerhafte Eingabe"
Exit Sub
End If
End Sub
Public
Function FeierTag(Datum As Date) As String
Dim Jahr As Integer
Jahr = Year(Datum)
If (Jahr > 1904) And (Jahr < 2100) Then
Select Case Format$(Datum, "dd.mm")
' Gesetzliche Feiertage
Case "01.01": FeierTag = "Neujahr"
Case "06.01": FeierTag = "Heilige Drei Könige"
Case "01.05": FeierTag = "Tag der Arbeit"
Case "15.08": FeierTag = "Mariä Himmelfahrt"
Case "03.10": FeierTag = "Tag der Deutschen Einheit"
Case "31.10": FeierTag = "Reformationstag"
Case "01.11": FeierTag = "Allerheiligen"
Case "24.12": FeierTag = "Heiligabend"
Case "25.12": FeierTag = "1. Weihnachtsfeiertag"
Case "26.12": FeierTag = "2. Weihnachtsfeiertag"
Case "31.12": FeierTag = "Sylvester"
Case Else
' Bewegliche Feste:
Select Case Datum - OsterSonntag(Datum)
Case -52: FeierTag = "Weiberfastnacht"
Case -48: FeierTag = "Rosenmontag"
Case -2: FeierTag = "Karfreitag"
Case 0: FeierTag = "Ostersonntag"
Case 1: FeierTag = "Ostermontag"
Case 39: FeierTag = "Christi Himmelfahrt"
Case 49: FeierTag = "Pfingstsonntag"
Case 50: FeierTag = "Pfingstmontag"
Case 60: FeierTag = "Fronleichnam"
Case Else
If Datum = CDate("25.12." & Jahr) - Weekday("25.12." & Jahr, _
vbMonday) - 32 Then
FeierTag = "Buß- und Bettag"
Else
FeierTag = vbNullString ' Kein Feiertag
End If
End Select
End Select
Else: FeierTag = vbNullString
End If
End Function
Public
Function OsterSonntag(Datum As Date) As Date
Dim A As Integer, D As Integer, E As Integer, Jahr As Integer
Jahr = Year(Datum)
If (1904 < Jahr) And (Jahr < 2100) Then ' Datum zulässig ?
A = Jahr Mod 19
D = (19 * A + 24) Mod 30
E = (2 * (Jahr Mod 4) + 4 * (Jahr Mod 7) + 6 * D + 5) Mod 7
OsterSonntag = CDate(DateSerial(Jahr, 3, 22 + D + E))
If Month(OsterSonntag) = 4 Then
If Day(OsterSonntag) = 26 Or (Day(OsterSonntag) = 25 And E = 6 And A > 10) Then
OsterSonntag = OsterSonntag - 7
End If
End If
End If
End Function
Gruß UweD
(Rückmeldung wäre schön)