Oversigtskalender som de trykte - skabelon/ II

det sker ikke i min, her er koden

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

Tak for det - øhh, er der ændringer i forhold til den kode, du lagde ud 9. juni?

nææ, det tror jeg ikke, men for en sikkerhedsskyld.

Men når du har kørt makroen, så laver den ikke mere i arket, så det er ikke kodens skyld.


Det undrede mig bare at du havde 1. oktober i L36, i min er den i L35.

Har lige prøvet begge kodeudgaver - de er forskellige, bl.a. er visse helligdage orange i ovenstående version. I 'min version' har jeg kopieret 2004-bjælken ind oven for 2. halvår, deraf L36. Det skulle jeg nok lige have nævnt. Muligvis er det her, hunden ligger begravet. Jeg prøver at tjekke, om referencetyperne er korrekte? 

I din version af 9. juni mangler en lodret adskillelsesstreg mellem september og oktober, men det er kun kosmetisk. Til gengæld lykkes det mig ikke at sætte den ind. Tak for hjælp. Send venligst et svar for points./ber

et svar ;-))