msdoc

VBA-Script

Option Explicit

Sub Kalender()
Dim jahr As Integer
Dim monat As Integer
Dim tag As Integer
Dim x As Integer

jahr = InputBox("Welches Jahr?")

Range("A1:BI33").ClearContents
Range("A1:BI33").Interior.ColorIndex = xlColorIndexNone
'Range("A2:BI33").Interior.ColorIndex = 5
Range("A1:BI33").Font.Size = 6
Range("A1:BI33").Font.Name = "Arial"
'Range("A1:BI33").Font.ColorIndex = 3
Range("A1:BI33").HorizontalAlignment = xlCenter
Range("A1:BI33").VerticalAlignment = xlCenter
Range("A1:BI1").RowHeight = 9
Range("A2:BI33").RowHeight = 12
Range("A1:A33").ColumnWidth = 1
Range("B1:BI33").ColumnWidth = 2.2
Range("B2:BI33").BorderAround LineStyle:=xlContinuous, Weight:=xlThick
Range("B2:BI2").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("G31:K31").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("Q32:U32").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("AA32:AE32").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("AP32:AT32").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("AZ32:BD32").Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("A2:BI2").NumberFormat = "@"
Range("A2:BI2").Font.Size = 8
Range("A2:BI2").Font.Bold = True
Cells(2, 4) = "1   Januar"
Cells(2, 9) = "2   Februar"
Cells(2, 14) = "3   März"
Cells(2, 19) = "4   April"
Cells(2, 24) = "5   Mai"
Cells(2, 29) = "6   Juni"
Cells(2, 34) = "7   Juli"
Cells(2, 39) = "8   August"
Cells(2, 44) = "9   September"
Cells(2, 49) = "10   Oktober"
Cells(2, 54) = "12   November"
Cells(2, 59) = "12   Dezember"
Range("G32:K33").MergeCells = True
Range("G32:K33").Font.Size = 20
Range("G32:K33").Font.Bold = True
Cells(32, 7) = jahr

' Farbe hellgrau = 15
' Farbe dunkelgrau = 48

For monat = 1 To 12 Step 1
  For tag = 1 To Day(DateSerial(jahr, monat + 1, 0))
    x = (monat - 1) * 5
    Range(Cells(2, x + 6), Cells(33, x + 6)).Borders(xlEdgeRight).LineStyle = xlContinuous
    Cells(tag + 2, x + 2) = Format(DateSerial(jahr, monat, tag), "DD")
    Cells(tag + 2, x + 3) = Format(DateSerial(jahr, monat, tag), "DDD")
    If Cells(tag + 2, x + 3) = "Sa" Then Range(Cells(tag + 2, x + 2), Cells(tag + 2, x + 6)).Interior.ColorIndex = 15
    If Cells(tag + 2, x + 3) = "So" Then Range(Cells(tag + 2, x + 2), Cells(tag + 2, x + 6)).Interior.ColorIndex = 48
    If Cells(tag + 2, x + 3) = "Mo" Then Cells(tag + 2, x + 4) = kalwo(DateSerial(jahr, monat, tag))
    If DateSerial(jahr, monat, tag) = Ostern(jahr) - 47 Then Cells(tag + 2, x + 5) = "Fasching"
    If DateSerial(jahr, monat, tag) = Ostern(jahr) - 2 Then
       Cells(tag + 2, x + 5) = "Karfreitag"
       Range(Cells(tag + 2, x + 2), Cells(tag + 2, x + 6)).Interior.ColorIndex = 48
    End If
    If DateSerial(jahr, monat, tag) = Ostern(jahr) Then Cells(tag + 2, x + 5) = "Ostern"
    If DateSerial(jahr, monat, tag) = Ostern(jahr) + 1 Then Range(Cells(tag + 2, x + 2), Cells(tag + 2, x + 6)).Interior.ColorIndex = 48
    If DateSerial(jahr, monat, tag) = Ostern(jahr) + 39 Then
       Cells(tag + 2, x + 5) = "Chr.Himmelf."
       Range(Cells(tag + 2, x + 2), Cells(tag + 2, x + 6)).Interior.ColorIndex = 48
    End If
    If DateSerial(jahr, monat, tag) = Ostern(jahr) + 49 Then
       Cells(tag + 2, x + 5) = "Pfingsten"
       Range(Cells(tag + 2, x + 2), Cells(tag + 2, x + 6)).Interior.ColorIndex = 48
    End If
    If DateSerial(jahr, monat, tag) = Ostern(jahr) + 50 Then Range(Cells(tag + 2, x + 2), Cells(tag + 2, x + 6)).Interior.ColorIndex = 48
    If DateSerial(jahr, monat, tag) = Ostern(jahr) + 60 Then
       Cells(tag + 2, x + 5) = "Fronleich."
       Range(Cells(tag + 2, x + 2), Cells(tag + 2, x + 6)).Interior.ColorIndex = 48
    End If
  Next tag
Next monat

Range("B3:F3").Interior.ColorIndex = 48
Cells(3, 5).HorizontalAlignment = xlLeft
Cells(3, 5) = "Neujahr"
Range("B8:F8").Interior.ColorIndex = 48
Cells(8, 5).HorizontalAlignment = xlLeft
Cells(8, 5) = "3 Könige"
Range("V3:Z3").Interior.ColorIndex = 48
Cells(3, 25).HorizontalAlignment = xlLeft
Cells(3, 25) = "Maifeiertag"
Range("AU5:AY5").Interior.ColorIndex = 48
Cells(5, 50).HorizontalAlignment = xlLeft
Cells(5, 50) = "Dt.Einheit"
Range("AZ3:BD3").Interior.ColorIndex = 48
Cells(3, 55).HorizontalAlignment = xlLeft
Cells(3, 55) = "Allerhl."
Range("BE26:BI28").Interior.ColorIndex = 48
Range("BH26:BH28").HorizontalAlignment = xlLeft
Cells(26, 60) = "Hl.Abend"
Cells(27, 60) = "Weihnacht"
Cells(28, 60) = "Weihnacht"
Range("BE33:BI33").Interior.ColorIndex = 48
Cells(33, 60).HorizontalAlignment = xlLeft
Cells(33, 60) = "Silvester"

End Sub

Function kalwo(Datum As Date) As Integer
  Dim t As Date
  t = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
  kalwo = (Datum - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function

Function Ostern(Yr As Integer) As Date
  Dim D As Integer
  D = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
  Ostern = DateSerial(Yr, 3, 1) + D + (D > 48) + 6 - _
  ((Yr + Yr \ 4 + D + (D > 48) + 1) Mod 7)
End Function