Attribute VB_Name = "Kalender"
Option Explicit 
Dim tblTable As Table
Dim strMonat(12) As String 
Dim data As Date 
Dim strMonatstrActTag(12, 31) As Integer 
Dim strWochentag, strActMonat, strActTag As String 
Dim oDoc As Document
Dim tblActCell As Cell
Dim intStartMonat, intJahr, intStartJahr, intMaxMonate As Integer 
Dim intMonat, intSpalte As Integer 
Dim strmsg As String 
Const cTitle = "Kalender erstellen"
System.Cursor = wdCursorWait 
' Daten abfragen 
Do 
  strmsg = "In welchem Jahr beginnt der Kalendar?"
  intStartJahr = InputBox(strmsg, cTitle, Year(Now))
  If intStartJahr = "" Then End 
Loop While IsNumeric(intStartJahr) = False 
Do 
  strmsg = "Mit welchem Monat soll der Kalender beginnen (1-12)?"
  intStartMonat = InputBox(strmsg, cTitle, Month("1/ 1/" & intStartJahr))
  If intStartJahr = "" Then End 
Loop While (Not IsNumeric(intStartMonat)) Or 1> intStartMonat Or intStartMonat >12
Do 
  strmsg = "Wie viele Monate sollen angezeigt werden (1-12)?"
  intMaxMonate = InputBox(strmsg, cTitle, "12")
  If intStartJahr = "" Then End 
Loop While IsNumeric(intMaxMonate) = False 
intJahr = intStartJahr
' Datum des ersten Kalendertages ermitteln 
data = "1/ " & Val(intStartMonat) & "/ " & intJahr
strWochentag = Weekday(data)
' Neues Dokument anlegen und ausrichten 
Set oDoc = Documents.Add
oDoc.PageSetup.PaperSize = wdPaperA4 
oDoc.PageSetup.Orientation = wdOrientLandscape 
'GoTo weiter: 
' Tabelle anlegen 
Set tblTable = oDoc.Tables.Add(Selection.Range, 32, intMaxMonate)
With tblTable
  intMonat = intStartMonat
  For intSpalte = 1 To intMaxMonate
    ' Jahreswechsel
    If intMonat = 13 Then 
      intMonat = 1
      intJahr = intJahr + 1
    End If 
    'Monatsnamen ermitteln
    strMonat(intMonat) = Format("1/" & intMonat & "/ " & intJahr, "mmmm")
    DoEvents 
    Set tblActCell = .Cell(1, intSpalte)
    ' Kopfzeile mit Monatsnamen formatieren
    With tblActCell
      .Range.InsertAfter strMonat(intMonat)
      .Range.Font.Bold = True 
      .Range.Font.Size = 11
      .Shading.BackgroundPatternColor = wdColorGray25
    End With 
    ' Jahreswechsel hervorheben
    If intMonat = 12 Then 
      .Columns(intSpalte).Borders(wdBorderRight).LineStyle = wdLineStyleDoubleWavy
    End If 
    strActMonat = Format(data, "mm")
    ' Alle Tage eines Monats bearbeiten
    Do While Val(strActMonat) = intMonat
      strActTag = Format(data, "dd")
      Set tblActCell = .Cell(strActTag + 1, intSpalte)
      With tblActCell
        .Range.InsertAfter Format(data, "d")
        .Range.Font.Bold = False 
        .Range.Font.Size = 8
        .Height = 12
        .VerticalAlignment = wdCellAlignVerticalCenter 
        ' Tageskürzel ermitteln und eintragen
        Select Case Weekday(data)
        Case vbSunday 
          .Range.InsertAfter " So"
          ' Sonntage werden hervorgehoben
          .Range.Shading.BackgroundPatternColor = wdColorGray25
        Case vbMonday 
          .Range.InsertAfter " Mo"
        Case vbTuesday 
          .Range.InsertAfter " Di"
        Case vbWednesday 
          .Range.InsertAfter " Mi"
        Case vbThursday 
          .Range.InsertAfter " Do"
        Case vbFriday 
          .Range.InsertAfter " Fr"
        Case vbSaturday 
          .Range.InsertAfter " Sa"
        End Select 
      End With 
      data = data + 1
      strActMonat = Format(data, "mm")
    Loop 
    ' nächster Monat
    intMonat = intMonat + 1
  Next intSpalte
End With 
weiter:
' Überschrift in Kopfzeile erstellen 
Dim oHeader As View
Dim msg As String 
Dim intEndMonat, intEndJahr, int_berlauf As Integer 
' Jahreswechsel berücksichtigen und korrekten Endmonat ermitteln 
If intStartMonat + intMaxMonate - 1 > 12 Then 
  int_berlauf = Int((intStartMonat + intMaxMonate - 1) / 12)
  intEndMonat = intStartMonat + intMaxMonate - 1 - 12 * int_berlauf
  intEndJahr = intStartJahr + int_berlauf
ElseIf intStartMonat + intMaxMonate - 1 = 12 Then
  intEndMonat = intStartMonat + intMaxMonate - 1
  intEndJahr = intStartJahr
Else 
  intEndMonat = intStartMonat + intMaxMonate - 1
  intEndJahr = intStartJahr + Int((intStartMonat + intMaxMonate - 1) / 12)
End If 
' Text für die Kopfzeile zusammensetzen 
msg = "Kalenderübersicht von " & intStartMonat & " / " & intStartJahr & " bis " _
 & intEndMonat & " / " & intEndJahr
' _berschrift in Kopfzeile einfügen und formatieren 
Set oHeader = oDoc.ActiveWindow.View
oHeader.SplitSpecial = wdPaneCurrentPageHeader 
With Selection
  .InsertAfter msg
  .Font.Size = 12
  .Font.Bold = True 
  .Paragraphs.Alignment = wdAlignParagraphCenter 
End With 
' Ansicht zurücksetzen 
System.Cursor = wdCursorNormal 
oHeader.SplitSpecial = wdPaneNone 
End Sub