Makro og VBA - Kalender vbap

Å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