Til kabbak. Kalender

Nu har jeg fundet ud af at udfylde dato, ugedag og  feltet derefter såfremt det er lørdag eller søndag. Men kan ikke finde ud af at rette i VBA således at også helligdage bliver udfyldt på samme måde (udfyldt = baggrundsfarve)

"Er det muligt at lave en eller anden funktion til en fødselsdagsliste sådan at kalenderen også medtager fødselsdage og såfremt det er en helligdag bibeholder farven fra helligdagslisten? Jeg vil gerne have skrevet såvel helligdagsnavnet som fødselsdagsnavnet i samme celle hvis det overhovedet kan lade sig gøre.
"

Det må du selv arbejde videre med, det andet er lavet, der er kun rette i den sub, der hedder kalender.

Public Sub Kalender()
    Dim År As Integer, Dato As Date, DD As Long, Md As Variant, Dag As Variant, HD As String, A As Integer, K As Integer
    Dim Olddato As Date, I As Integer
    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.DisplayAlerts = False    ' vi får alarm, når vi fletter celler, hvor vi har sat data i den første, de alarmer, vil vi ikke se
    Cells.MergeCells = False    ' fjerner fletning på celler
    Cells.Interior.ColorIndex = xlNone    ' fjerner baggrundsfarver
    Cells.Font.ColorIndex = 0  ' fjerner tekstfarver
    Application.ScreenUpdating = False    ' vi vil ikke se på at skærmen opdateres
    ActiveSheet.Range("A1") = ""
    Range("A1:R1").Interior.ColorIndex = 1    ' baggrundsfarve for kalenderåret
    Range("A1:R1").Font.ColorIndex = 2    ' Tekstfarven på årstallet
    For A = 1 To 6
        Cells(2, (A * 3) - 2) = Md(A)    ' Skriver månedsnavne, på 1. halvår
        Range(Cells(2, (A * 3) - 2), Cells(2, (A * 3))).Merge    ' fletter de 3 felter med månedsnavne
        Cells(2, (A * 3) - 2).Font.Bold = True    ' månedsnavne med fed skrift
    Next
    Range("A2:R2").HorizontalAlignment = xlCenter
    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, 7
                Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 34    ' baggrundsfarve lørdag og søndag
            Case 2
                Cells(I, K + 2) = Cells(I, K + 2) & Space((15 - Len(HD)) * 1.2) & DatePart("ww", Dato, vbMonday, vbFirstFourDays)
            End Select
            If HD <> "" Then
                Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 34    ' baggrundsfarve andre helligdage
            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 -------------

    For A = 7 To 12
        Cells(34, ((A - 6) * 3) - 2) = Md(A)    ' Skriver månedsnavne, på 3. halvår
        Range(Cells(34, ((A - 6) * 3) - 2), Cells(34, ((A - 6) * 3))).Merge    ' fletter de 3 felter med månedsnavne
        Cells(34, ((A - 6) * 3) - 2).Font.Bold = True    ' månedsnavne med fed skrift
    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 = 34    ' baggrundsfarve lørdag og søndag
            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 + 2)).Interior.ColorIndex = 34    ' baggrundsfarve lørdag og søndag
            End Select

            If HD <> "" Then
                Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 34    ' baggrundsfarve andre helligdage
            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
    Rows("1:1").EntireRow.AutoFit
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

lukker

hvad mener du, kan du ikke bruge koden ??
Den skulle være som du ønsker, bortset fra det sidste.

Sorry - jeg var lidt for hurtig på tasterne. Tak for hjælpen. Der var en enkelt "bug" på Range("A1:R1").Font.ColorIndex = 2    ' Tekstfarven på årstallet, men den har jeg fået rettet. :-)