Avatar billede sjomka2001 Nybegynder
30. november 2012 - 17:58 Der er 5 kommentarer og
1 løsning

Hvordan gør jeg dette? Formatering af kalender via vba!

Al kredit til kabbak, som jeg har fået denne fra!

Hvordan ændrer jeg vba'en til at farve alle 3 felter samme farve såfremt det er en lørdag, søndag eller helligdag. Kør nedenstående og se f.eks. store bededag den 4. maj. Her vil jeg gerne have formateret alle 3 felter til at være samme farve.

Det skal gælde over hele arket såfremt det er lørdag, søndag, helligdag.

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øndag", "Mandag", "Tirsdag", "Onsdag", "Torsdag", "Fredag", "Lørdag")
    År = InputBox(" Indtast årstal for kalender")
    Application.ScreenUpdating = False
    Cells.MergeCells = False
    ActiveSheet.Range("A1") = ""
    Range("A1:R1").Interior.ColorIndex = 48
    Range("A1:R2").Font.Bold = True
    Range("A2:R2").Interior.ColorIndex = 15
    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 = 15
            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 = 48
    Range("A34:R34").Font.Bold = True
    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 = 15
            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 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 Else
    End Select
    OK = False
End Function
Avatar billede store-morten Ekspert
30. november 2012 - 18:51 #1
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øndag", "Mandag", "Tirsdag", "Onsdag", "Torsdag", "Fredag", "Lørdag")
    År = InputBox(" Indtast årstal for kalender")
    Application.ScreenUpdating = False
    Cells.MergeCells = False
    ActiveSheet.Range("A1") = ""
    Range("A1:R1").Interior.ColorIndex = 48
    Range("A1:R2").Font.Bold = True
    Range("A2:R2").Interior.ColorIndex = 15
    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 + 2)).Interior.ColorIndex = 15
            End Select
            If HD <> "" Then
                Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15
            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 = 48
    Range("A34:R34").Font.Bold = True
    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 + 2)).Interior.ColorIndex = 15
            End Select

            If HD <> "" Then
                Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15
            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 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 Else
    End Select
    OK = False
End Function
Avatar billede sjomka2001 Nybegynder
04. december 2012 - 17:12 #2
Super. Det virker perfekt som altid. Tak for hjælpen - og hvordan er det nu lige man giver point?
Avatar billede store-morten Ekspert
04. december 2012 - 20:00 #3
Velbekomme.

Jeg lægger et 'Svar' (til løsninger og pointgivning) som du kan acceptere.
Avatar billede store-morten Ekspert
04. december 2012 - 21:30 #4
Overskriften for måned, flettet og centreret.

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øndag", "Mandag", "Tirsdag", "Onsdag", "Torsdag", "Fredag", "Lørdag")
    År = InputBox(" Indtast årstal for kalender")
    Application.ScreenUpdating = False
    Cells.MergeCells = False
    ActiveSheet.Range("A1") = ""
    Range("A1:R1").Interior.ColorIndex = 48
    Range("A1:R2").Font.Bold = True
    Range("A2:R2").Interior.ColorIndex = 15
    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 + 2)).Interior.ColorIndex = 15
            End Select
            If HD <> "" Then
                Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15
            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 = 48
    Range("A34:R34").Font.Bold = True
    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 + 2)).Interior.ColorIndex = 15
            End Select

            If HD <> "" Then
                Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15
            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("A2:C2, D2:F2, G2:I2, J2:L2, M2:O2, P2:R2").Merge
    Range("A34:C34, D34:F34, G34:I34, J34:L34, M34:O34, P34:R34").Merge
    Range("A1:R1").Borders.LineStyle = xlContinuous
    Range("A1:R1").HorizontalAlignment = xlCenter
    Range("A2:C2, D2:F2, G2:I2, J2:L2, M2:O2, P2:R2").HorizontalAlignment = xlCenter
    Range("A34:C34, D34:F34, G34:I34, J34:L34, M34:O34, P34:R34").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 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 Else
    End Select
    OK = False
End Function
Avatar billede store-morten Ekspert
04. december 2012 - 22:00 #5
Overskriften for måned, flettet og centreret.
Ugenummer sat så langt til højre som muligt. (Ved: Helligdag + Ugenummer)

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øndag", "Mandag", "Tirsdag", "Onsdag", "Torsdag", "Fredag", "Lørdag")
    År = InputBox(" Indtast årstal for kalender")
    Application.ScreenUpdating = False
    Cells.MergeCells = False
    ActiveSheet.Range("A1") = ""
    Range("A1:R1").Interior.ColorIndex = 48
    Range("A1:R2").Font.Bold = True
    Range("A2:R2").Interior.ColorIndex = 15
    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)) * 3.9) & DatePart("ww", Dato, vbMonday, vbFirstFourDays)
            Case 7
                Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15
            End Select
            If HD <> "" Then
                Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15
            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 = 48
    Range("A34:R34").Font.Bold = True
    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)) * 3.9) & DatePart("ww", Dato, vbMonday, vbFirstFourDays)
            Case 7
                Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15
            End Select

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

            HD = ""
            Cells(i, k + 1) = Day(Dato)

            Dato = Dato + 1
            If Month(Dato) <> Month(Olddato) Then Exit For
        Next
    Next
    Range("A3:R33,A35:R65").Font.Size = 8
    Range("A3:R33,A35:R65").Borders.LineStyle = xlContinuous
    Columns("A:R").EntireColumn.AutoFit
    Range("C:C,F:F,I:I,L:L,O:O,R:R").ColumnWidth = 13.56
    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 = 98
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
    End With
    Range("A1:R1").Merge
    Range("A2:C2, D2:F2, G2:I2, J2:L2, M2:O2, P2:R2").Merge
    Range("A34:C34, D34:F34, G34:I34, J34:L34, M34:O34, P34:R34").Merge
    Range("A1:R1").Borders.LineStyle = xlContinuous
    Range("A1:R1").HorizontalAlignment = xlCenter
    Range("A2:C2, D2:F2, G2:I2, J2:L2, M2:O2, P2:R2").HorizontalAlignment = xlCenter
    Range("A34:C34, D34:F34, G34:I34, J34:L34, M34:O34, P34:R34").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 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 Else
    End Select
    OK = False
End Function
Avatar billede sjomka2001 Nybegynder
07. december 2012 - 17:25 #6
Super! Det funker! Tak for hjælpen.
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester