Quelltext ist hier: Private Sub Kalender_Click()
Dim ws As Worksheet Dim strMeldung As String Dim strTitel As String Dim strAntwort As String Dim varYear As Variant Dim bytMonth As Byte Dim bytDay As Byte Dim bytWeekday As Byte Dim strWeekday As String Dim bytWeeknumber As Byte Dim bytDummy As Byte
' Das Jahr des Kalenders der ausgegeben werden soll
strMeldung = "Geben Sie das Jahr ein!" strTitel = "Eingabe Jahr"
strAntwort = InputBox(strMeldung, strTitel) varYear = strAntwort
' Falls bereits ein Blatt mit dem Namen "Jahr xxxx" entsteht, ' soll dieses gelöscht werden For Each ws In Worksheets If ws.Name = "Jahr " & varYear Then ws.Delete End If Next ws
' Ein neues Tabellenblatt mit dem Namen "Jahr xxxx" einfügen Worksheets.Add ActiveSheet.Name = "Kalender"
' Monatsüberschriften einfügen und formatieren
For bytMonth = 1 To 12
With Worksheets("Kalender").Range("A1;L35") = Worksheets("Kalender").Cells = "bytMonth"
.Value = Format(DateSerial(varYear, bytMonth, 1), "mmmm")
.Interior.ColorIndex = 36
.Font.Bold = True
End With
' Tage aufbereiten
For bytDay = 1 To Day(DateSerial(varYear, bytMonth + 1, 0))
With Cells(bytDay + 1, bytMonth)
bytWeekday = Weekday(DateSerial(varYear, bytMonth, bytDay))
' Wochentage in Textformat aufbereiten
Select Case bytWeekday
Case 1
strWeekday = "So"
Case 2
strWeekday = "Mo"
Case 3
strWeekday = "Di"
Case 4
strWeekday = "Mi"
Case 5
strWeekday = "Do"
Case 6
strWeekday = "Fr"
Case 7
strWeekday = "Sa"
End Select
' Wochentage und Tage eintragen
.Value = strWeekday & ", " & bytDay
' Samstage hellgrau hervorheben
If bytWeekday = 7 Then
.Interior.ColorIndex = 15
End If
' Sonntage dunkelgrau hervorheben
If bytWeekday = 1 Then
.Interior.ColorIndex = 48
End If
' Kalenderwoche eintragen
bytWeeknumber = _
Format(DateSerial(varYear, bytMonth, bytDay), "ww")
If bytDummy < bytWeeknumber And strWeekday <> "So" Then
bytDummy = bytWeeknumber
.Value = .Value & " (" & bytDummy & ")"
' Formatierung Kalenderwoche
With .Characters _
(Start:=InStr(1, .Value, "("), Length:=4).Font
.Size = 8
.Color = vbRed
End With
End If
End With
Next bytDay
Next bytMonth End Sub