Åben et tomt regneark, højreklik på arknavn (i bunden), vælg vis programkode, indsæt nedenstående kode i visual basic, vend tilbage til arket, tryk alt+f8, vælg "Afspil", du skulle nu kunne vælge årstal for den ønskede kalender.

Function Påskedag(InputYear As Integer) As Long ' Returnerer datoen for Påskedag
Dim d As Integer
    d = (((255 - 11 * (InputYear Mod 19)) - 21) Mod 30) + 21
    Påskedag = DateSerial(InputYear, 3, 1) + d + (d > 48) + 6 - _
        ((InputYear + InputYear \ 4 + d + (d > 48) + 1) Mod 7)
End Function

Function HelligdagsNavn(lngdate As Long) As String
' bruger funktionen Påskedag
Dim InputYear As Integer, PD As Long, OK As Boolean
    If lngdate <= 0 Then lngdate = Date
    InputYear = Year(lngdate)
    PD = Påskedag(InputYear)
      OK = True
    Select Case lngdate ' Tester nedenstående påstande mod datoen
        Case DateSerial(InputYear, 1, 1): HelligdagsNavn = "Nytårsdag"
        Case PD - 3: HelligdagsNavn = "Skærtorsdag"
        Case PD - 2: HelligdagsNavn = "Langfredag"
        Case PD: HelligdagsNavn = "Påskedag"
        Case PD + 1: HelligdagsNavn = "2. Påskedag"
        Case DateSerial(InputYear, 6, 5): HelligdagsNavn = "Grundlovsdag"
        Case PD + 26: HelligdagsNavn = "Store Bededag"
        Case PD + 39: HelligdagsNavn = "Kristi Himmelfartsdag"
        Case PD + 49: HelligdagsNavn = "Pinsedag"
        Case PD + 50: HelligdagsNavn = "2. Pinsedag"
        Case DateSerial(InputYear, 12, 24): HelligdagsNavn = "Julaftensdag"
        Case DateSerial(InputYear, 12, 25): HelligdagsNavn = "1.Juledag"
        Case DateSerial(InputYear, 12, 26): HelligdagsNavn = "2.Juledag"
        Case DateSerial(InputYear, 12, 31): HelligdagsNavn = "Nytårsaftensdag"
        Case Else
      End Select
        OK = False
End Function
Public Sub Kalender()
Dim År As Integer, Dato As Date, DD As Long, Md As Variant, Dag As Variant, HD As String
Md = Array("", "Januar", "Febuar", "Marts", "April", "Maj", "Juni", "Juli", "August", "September", "Oktober", "November", "December")
Dag = Array("", "S", "M", "T", "O", "T", "F", "L")
År = InputBox(" Indtast årstal for kalender")
Application.ScreenUpdating = False
Cells.MergeCells = False
Range("A1") = ""
Range("A1:R1").Interior.ColorIndex = 50
Range("A2:R2").Interior.ColorIndex = 38
Range("A3:R33").Font.ColorIndex = xlAutomatic
Range("A35:R65").Font.ColorIndex = xlAutomatic
For a = 1 To 6
Cells(2, a * 3) = Md(a)
Next
Dato = "01-01-" & År
For K = 1 To 18 Step 3
Call MDRamme(K, 2)
Olddato = Dato
For I = 3 To 33
DD = DateValue(Dato)
HD = HelligdagsNavn(DD)
Cells(I, K) = Dag(Weekday(Dato))
Select Case Weekday(Dato)
Case 1, 7
    Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 15
    Cells(I, K + 2) = HD
  Case 2
    Cells(I, K + 2) = ""
    Cells(I, K + 2) = "'" & DatePart("ww", Dato, vbMonday, vbFirstFourDays) & " " & HD
  If HD = "" Then
    Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone
  Else
    Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 40
  End If
 
  Cells(I, K + 2).Font.ColorIndex = xlAutomatic
  If IsNumeric(Left(Cells(I, K + 2).Value, 1)) And IsNumeric(Mid(Cells(I, K + 2).Value, 1, 1)) Then
      Cells(I, K + 2).Characters(Start:=1, Length:=2).Font.ColorIndex = 5
  Else
      Cells(I, K + 2).Characters(Start:=1, Length:=1).Font.ColorIndex = 5
  End If
Case Else
  Cells(I, K + 2) = HD
  If HD = "" Then
  Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone
  Else
  Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 40
  End If
End Select
Cells(I, K + 1) = Day(Dato)
HD = ""
Dato = Dato + 1
If Month(Dato) <> Month(Olddato) Then Exit For
Next
Next

' -----------------næste halve år -------------
Range("A34:R34").Interior.ColorIndex = 38
For a = 7 To 12
  Cells(34, (a - 6) * 3) = Md(a)
Next
For K = 1 To 18 Step 3
Call MDRamme(K, 34)
For I = 35 To 65
Olddato = Dato
DD = DateValue(Dato)
HD = HelligdagsNavn(DD)
Cells(I, K) = Dag(Weekday(Dato))
Select Case Weekday(Dato)
Case 1, 7
    Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 15
    Cells(I, K + 2) = HD
Case 2
  Cells(I, K + 2) = "'" & DatePart("ww", Dato, vbMonday, vbFirstFourDays) & " " & HD
  If HD = "" Then
    Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone
  Else
    Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 40
  End If
  Cells(I, K + 2).Font.ColorIndex = xlAutomatic
  If IsNumeric(Left(Cells(I, K + 2).Value, 1)) And IsNumeric(Mid(Cells(I, K + 2).Value, 1, 1)) Then
      Cells(I, K + 2).Characters(Start:=1, Length:=2).Font.ColorIndex = 5
  Else
      Cells(I, K + 2).Characters(Start:=1, Length:=1).Font.ColorIndex = 5
  End If
Case Else
  Cells(I, K + 2) = HD
  If HD = "" Then
  Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone
  Else
  Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 40
  End If
End Select
  HD = ""
  Cells(I, K + 1) = Day(Dato)
  Dato = Dato + 1
  If Month(Dato) <> Month(Olddato) Then Exit For
Next
Next
    Range("A1:R65").Select
    Range("R65").Activate
    Range("A3:R33,A35:R65").Font.Size = 8
    Range("A3:R33,A35:R65").Borders.LineStyle = xlContinuous
    Columns("A:R").Select
    Columns("A:R").EntireColumn.AutoFit
    Range("C:C,F:F,I:I,L:L,O:O,R:R").ColumnWidth = 10
    Rows("34:34").Select
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
    Range("3:33,35:65").RowHeight = 12
    ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"
  With ActiveSheet.PageSetup
        .Orientation = xlLandscape
        .Zoom = 120
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
    End With
    Range("A1:R1").Merge
    Range("A1:R1").Borders.LineStyle = xlContinuous
    Range("A1:R1").HorizontalAlignment = xlCenter
    Range("A1") = År
    Range("A1").Select
  Application.ScreenUpdating = True
End Sub
Sub MDRamme(KO, RK)
    Range(Cells(RK, KO), Cells(RK, KO + 2)).Select
        With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
End Sub