Kalender 2008
Tillad mig her i starten af det nye år, at gøre opmærksom på kabbak's kalender. (jeg mener den er det værd). Har forresten tilladt mig at gøre ugenummerne blå.kør 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
