Sepp hat mit freundlicherweise einen Code zur verfügung gestellt,
der folgendes ermöglicht:
Bei Anderung der Jahreszahl mittels Drehfeld in A1 werden die
Wochentage und formatierungen der Wochenenden sowie die Feiertage
neu berechnet. Soweit ist auch alles perfekt!!!
Nun würde ich gerne aus Gestalltungsgründen den gesamten Kalender
gerne verschieben.
Die bisherige Position beginnend in B3, die neue soll jetzt in C2.
Wo, muß jetzt genau etwas geändert werden?
Ich bekomme es einfach nicht hin.
Hier Sepp´s Code:
Option Explicit
Sub jahreskalender()
Dim iCol As Integer, iMonth As Integer
Dim lRow As Long
Dim strFeiertage As String
Dim rng As Range
On Error GoTo ErrExit
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Sheets("Kalender")
With .[B4:AF86]
.ClearContents
.Interior.ColorIndex = xlNone
.Font.Bold = False
.Font.ColorIndex = xlAutomatic
On Error Resume Next
.SpecialCells(xlCellTypeComments).ClearComments
On Error GoTo ErrExit
End With
For lRow = 3 To 81
Select Case lRow
Case 3, 10, 17, 24, 31, 38, 45, 52, 59, 66, 73, 80
iMonth = iMonth + 1
.Cells(lRow, 2) = Format(DateSerial(.[A1], iMonth, 1), "MMMM YYYY")
Case 4, 11, 18, 25, 32, 39, 46, 53, 60, 67, 74, 81
For iCol = 2 To Day(DateSerial(.[A1], iMonth + 1, 0)) + 1
.Cells(lRow, iCol) = iCol - 1 & "."
.Cells(lRow + 1, iCol) = Format(DateSerial(.[A1], iMonth, iCol - 1), "ddd")
If Weekday(DateSerial(.[A1], iMonth, iCol - 1), vbMonday) > 5 Then
.Range(.Cells(lRow, iCol), .Cells(lRow + 5, iCol)).Interior.ColorIndex = 15
End If
strFeiertage = Feiertage(DateSerial(.[A1], iMonth, iCol - 1))
If strFeiertage <> "" Then
.Range(.Cells(lRow, iCol), .Cells(lRow + 1, iCol)).Font.Bold = True
.Range(.Cells(lRow, iCol), .Cells(lRow + 1, iCol)).Font.ColorIndex = 3
.Cells(lRow, iCol).AddComment (strFeiertage)
.Cells(lRow, iCol).Comment.Shape.TextFrame.AutoSize = True
End If
Next
Case Else
End Select
Next
End With
ErrExit:
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function Feiertage(Datum As Date)
Dim J As Integer
Dim O As Date
J = Year(Datum)
O = Ostern(J)
Select Case Datum
Case Is = DateSerial(J, 1, 1)
Feiertage = "Neujahr"
Case Is = DateSerial(J, 1, 6)
Feiertage = "Dreikönig"
Case Is = O
'##Von Ostern abgeleitete Fest- und Gedenktage
Feiertage = "Ostersonntag"
Case Is = DateAdd("D", 1, O)
Feiertage = "Ostermontag"
Case Is = DateSerial(J, 5, 1)
Feiertage = "Erster Mai"
Case Is = DateAdd("D", 39, O)
Feiertage = "Christi Himmelfahrt"
Case Is = DateAdd("D", 49, O)
Feiertage = "Pfingstsonntag"
Case Is = DateAdd("D", 50, O)
Feiertage = "Pfingstmontag"
Case Is = DateAdd("D", 60, O)
Feiertage = "Fronleichnam"
Case Is = DateSerial(J, 8, 15)
Feiertage = "Maria Himmelfahrt"
Case Is = DateSerial(J, 10, 26)
Feiertage = "National Feiertag"
Case Is = DateSerial(J, 11, 1)
Feiertage = "Allerheiligen"
Case Is = DateSerial(J, 12, 8)
Feiertage = "Maria Empfängnis"
Case Is = DateSerial(J, 12, 24)
Feiertage = "Heilig Abend"
Case Is = DateSerial(J, 12, 25)
Feiertage = "Christtag"
Case Is = DateSerial(J, 12, 26)
Feiertage = "Stefanitag"
Case Is = DateSerial(J, 12, 31)
Feiertage = "Silvester"
'##Von Weihnachten abgeleitete Fest- und Gedenktage
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 35
Feiertage = "Volkstrauertag"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 32
Feiertage = "Buss- u. Bettag"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 28
Feiertage = "Totensonntag/Ewigkeitssonntag"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 21
Feiertage = "1. Advent"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 14
Feiertage = "2. Advent"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2) - 7
Feiertage = "3. Advent"
Case Is = DateSerial(J, 12, 25) - Weekday(DateSerial(J, 12, 25), 2)
Feiertage = "4. Advent"
Case Else
Feiertage = ""
End Select
End Function
Function Ostern(Year As Integer)
Dim D As Integer
D = (((255 - 11 * (Year Mod 19)) - 21) Mod 30) + 21
Ostern = DateSerial(Year, 3, 1) + D + (D > 48) + 6 - _
((Year + Year \ 4 + D + (D > 48) + 1) Mod 7)
End Function
Gruß
Michael