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
