Eksempel for 2007
Kode til kalender i excel.

Sæt al kode ind i et module i excel, ikke et ark eller Thisworkbook modul.

Når det er gjort, vælg så afspil makro, fra arket , der bliver nu spurgt om årstal,
skriv det år du ønsker og det aktive ark får en kalender, for det pågældende år.


Kode:

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", "Februar", "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
    ActiveSheet.Range("A1") = ""
    Range("A1:R1").Interior.ColorIndex = 50
    Range("A2:R2").Interior.ColorIndex = 38
    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))
            Cells(i, k + 2) = HD
            Select Case Weekday(Dato)
            Case 1
                Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15
            Case 2
                Cells(i, k + 2) = Cells(i, k + 2) & Space((15 - Len(HD)) * 1.2) & DatePart("ww", Dato, vbMonday, vbFirstFourDays)
            Case 7
                Range(Cells(i, k), Cells(i, k + 1)).Interior.ColorIndex = 15
            End Select
            If HD <> "" Then
                Cells(i, k + 2).Interior.ColorIndex = 40
            End If

            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))
            Cells(i, k + 2) = HD
            Select Case Weekday(Dato)
            Case 1

                Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15
            Case 2
                Cells(i, k + 2) = Cells(i, k + 2) & Space((15 - Len(HD)) * 1.2) & DatePart("ww", Dato, vbMonday, vbFirstFourDays)
            Case 7
                Range(Cells(i, k), Cells(i, k + 1)).Interior.ColorIndex = 15
            End Select

            If HD <> "" Then
                Cells(i, k + 2).Interior.ColorIndex = 40
            End If

            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 = 12
    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

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 = "Juleaftensdag"
    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