ein rudimentärer ;-) Lösungsansatz mit ein paar Makros.
Aufruf erfolgt mit Jahreskalender zB aus dem Menü von Excel
Bei Problemen einfach nachfragen.
Gruß zum Schluß
---------------
Sub Jahreskalender()
Dim strJahr As String
Dim lngNumSheets As Long
Dim intI As Integer, intJahr As Integer
strJahr = InputBox("Kalender anlegen für Jahr:", , Year(Date))
If strJahr = "" Or Not IsNumeric(strJahr) Then Exit Sub
intJahr = CInt(strJahr)
lngNumSheets = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 12
Workbooks.Add
Application.SheetsInNewWorkbook = lngNumSheets
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Windows(1).Caption = "Jahreskalender " & strJahr
For intI = 1 To 12
Worksheets(intI).Activate
Call MonatAnlegen(intJahr, intI)
Next intI
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub MonatAnlegen(intJahr As Integer, intMonat As Integer)
Dim intI As Integer
Dim lngDate As Long
lngDate = CLng(DateSerial(intJahr, intMonat, 1))
ActiveSheet.Name = Format(lngDate, "mmmm") 'zB "Januar"
Range("A1") = "Datum"
Range("C1") = "Eintragung"
Range("D1") = "Geburtstage"
With Range("A1:D1")
With .Font
.Bold = True
.Size = 10
.ColorIndex = 6
End With
.Interior.ColorIndex = 11
End With
intI = DateSerial(intJahr, intMonat + 1, 1) - lngDate + 1
Range("A2") = lngDate
Range("A3").Formula = "=A2+1"
Range("A3:A" & intI).FillDown
Range("A2:A" & intI).Copy
Range("A2:A" & intI).PasteSpecial (xlValues)
Range("A2:A" & intI).NumberFormat = "dd.mm.yy"
Columns(1).Copy Columns(2)
Range("B1") = "Tag"
Range("B1").HorizontalAlignment = xlRight
Range("B2:B" & intI).NumberFormat = "dddd" 'zB "Samstag"
Range("C2").Select
intI = 2
Do Until IsEmpty(Cells(intI, 1))
Select Case WeekDay(Cells(intI, 1))
Case vbSaturday
Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 40 'Orange
Case vbSunday
Range(Cells(intI, 1), Cells(intI, 2)).Interior.ColorIndex = 3 'Rot
End Select
Cells(intI, 3).Value = Feiertag(Cells(intI, 1).Value)
intI = intI + 1
Loop
ActiveSheet.UsedRange.Columns.AutoFit
End Sub
'http://home.t-online.de/home/t.igel/xlostern.htm
Private Function Feiertag(datum As Long) As String
Dim temp As Variant
Feiertag = ""
Select Case Month(datum)
Case 1
Select Case Day(datum)
Case 1
Feiertag = "Neujahr"
Case 6
Feiertag = "Heiligen 3 Könige"
End Select
Case 2 To 6
osSo = OsterSo(Year(datum))
Select Case datum
Case osSo - 48
Feiertag = "Rosenmontag"
Case osSo - 47
Feiertag = "Fasching"
Case osSo - 46
Feiertag = "Aschermittwoch"
Case osSo - 2
Feiertag = "Karfreitag"
Case osSo - 1
Feiertag = "Karsamstag"
Case osSo
Feiertag = "Ostersonntag"
Case osSo + 1
Feiertag = "Ostermontag"
Case DateSerial(Year(datum), 5, 1)
Feiertag = "Tag der Arbeit"
Case osSo + 39
Feiertag = "Christi Himmelfahrt"
Case osSo + 48
Feiertag = "Pfingstsamstag"
Case osSo + 49
Feiertag = "Pfingstsonntag"
Case osSo + 50
Feiertag = "Pfingstmontag"
Case osSo + 60
Feiertag = "Fronleichnam"
End Select
Case 8
Select Case Day(datum)
Case 15
Feiertag = "Maria Himmelfahrt"
End Select
Case 10
Select Case Day(datum)
Case 3
Feiertag = "Tag der Dt. Einheit"
End Select
Case 11
temp = DateSerial(Year(datum), 12, 25)
Select Case datum
Case DateSerial(Year(datum), 11, 1)
Feiertag = "Allerheiligen"
Case (temp - WeekDay(temp, vbMonday) - 32)
Feiertag = "Buß- und Bettag"
End Select
Case 12
Select Case Day(datum)
Case 24
Feiertag = "Heilig Abend"
Case 25
Feiertag = "1. Weihnachtsfeiertag"
Case 26
Feiertag = "2. Weihnachtsfeiertag"
Case 31
Feiertag = "Silvester"
End Select
End Select
End Function
Private Function OsterSo(jahr As Integer) As Variant
Dim d As Variant
d = (((255 - 11 * (jahr Mod 19)) - 21) Mod 30) + 21
OsterSo = DateSerial(jahr, 3, 1) + d + (d > 48) + _
6 - ((jahr + jahr \ 4 + d + (d > 48) + 1) Mod 7)
End Function