Function WEEKNR(InputDate As Long) As Integer Dim a As Integer, b As Integer, c As Long, d As Integer WEEKNR = 0 If InputDate < 1 Then Exit Function a = Weekday(InputDate, vbSunday) b = Year(InputDate + ((8 - a) Mod 7) - 3) c = DateSerial(b, 1, 1) d = (Weekday(c, vbSunday) + 1) Mod 7 WEEKNR = Int((InputDate - c - 3 + d) / 7) + 1 End Function
Function glrPåskedag(intYear As Integer) As Variant ' Udregner påskedag for et givet årstal ' Beregningsmetode ifl. Gauss Dim a As Integer Dim b As Integer Dim c As Integer Dim d As Integer Dim e As Integer Dim k As Integer Dim p As Integer Dim q As Integer Dim M As Integer Dim n As Integer Dim intDay As Integer Dim intMonth As Integer
k = intYear \ 100 p = (13 + 8 * k) \ 25 q = k \ 4 M = (15 - p + k - q) Mod 30 n = (4 + k - q) Mod 7 'Debug.Print k, p, q, m, n a = intYear Mod 19 b = intYear Mod 4 c = intYear Mod 7 d = (19 * a + M) Mod 30 e = (2 * b + 4 * c + 6 * d + n) Mod 7
If d + e <= 9 Then intDay = 22 + d + e intMonth = 3 ElseIf (d = 29) And (e = 6) Then intDay = 19 intMonth = 4 ElseIf (d = 28) And (e = 6) And (a > 10) Then intDay = 18 intMonth = 4 Else intDay = d + e - 9 intMonth = 4 End If glrPåskedag = DateSerial(intYear, intMonth, intDay) End Function
Function Helligdag(intYear As Integer, Helligdagstype As Integer) As Variant
' Returnerer datoen for de forskydelige helligdage. ' Helligdagstypen angives med en af de prædefinerede konstanter
Select Case Helligdagstype Case SKÆRTORSDAG Helligdag = glrPåskedag(intYear) - 3 Case LANGFREDAG Helligdag = glrPåskedag(intYear) - 2 Case PÅSKEDAG Helligdag = glrPåskedag(intYear) Case PÅSKEDAG2 Helligdag = glrPåskedag(intYear) + 1 Case BEDEDAG Helligdag = glrPåskedag(intYear) + 26 Case KRISTIHIMMELFARTSDAG Helligdag = glrPåskedag(intYear) + 39 Case PINSEDAG Helligdag = glrPåskedag(intYear) + 49 Case PINSEDAG2 Helligdag = glrPåskedag(intYear) + 50 End Select End Function
Function IsHelligdag(dtmDate As Variant) As Integer ' Returnerer TRUE hvis dtmDate er en helligdag Dim intYear As Integer Dim dtmPåskedag As Variant
Select Case dtmDate - dtmPåskedag Case -3, -2, 0, 1, 26, 39, 49, 50 IsHelligdag = True Case Else If (Month(dtmDate) = 1) And (Day(dtmDate) = 1) Then IsHelligdag = True ' Nytårsdag ElseIf (Month(dtmDate) = 5) And (Day(dtmDate) = 1) Then IsHelligdag = True ' 1 Maj ElseIf (Month(dtmDate) = 6) And (Day(dtmDate) = 5) Then IsHelligdag = True ' Grundlovsdag ElseIf (Month(dtmDate) = 12) And (Day(dtmDate) = 25) Then IsHelligdag = True ' Juledag ElseIf (Month(dtmDate) = 12) And (Day(dtmDate) = 26) Then IsHelligdag = True ' 2. juledag End If End Select End Function
Public Sub MAIN() Dim x Dim errtext$ Dim maaned Dim aar Dim teller Dim dag Dim datosn
Dim informationer As Object: Set informationer = WordBasic.CurValues.UserDialog
start: x = WordBasic.Dialog.UserDialog(informationer, 1) On Error GoTo -1: On Error GoTo slut If x = 0 Then GoTo slut
'Checker dataene fra dialogboksen If WordBasic.Val(informationer.mdnr$) < 1 Then errtext$ = "Månedsnummer skal være større end 0" GoTo fejl End If If WordBasic.Val(informationer.mdnr$) > 12 Then errtext$ = "Månedsnummer skal være mindre end eller lig 12" GoTo fejl End If If WordBasic.Val(informationer.aar$) < 1900 Then errtext$ = "Makroen kan ikke håndtere årstal før 1900" GoTo fejl End If If WordBasic.Val(informationer.aar$) > 4000 Then errtext$ = "Makroen kan ikke håndtere årstal større end 4000" GoTo fejl End If If WordBasic.Val(informationer.antal$) < 1 Then errtext$ = "Antallet af måneder skal være større end 0" GoTo fejl End If If WordBasic.Val(informationer.antal$) > 12 Then errtext$ = "Makroen kan maksimalt håndtere 12 måneder" GoTo fejl End If
If ((Month(dtmDate) = 5) And (Day(dtmDate) = 1)) Or ((Month(dtmDate) = 6) And (Day(dtmDate) = 5)) Then Selection.Font.Size = 8 Else WordBasic.ShadingPattern 4 End If
Case Helligdag(CInt(aar), SKÆRTORSDAG) Selection.TypeText Text:="Skærtorsdag" WordBasic.WordLeft 2
Case Helligdag(CInt(aar), LANGFREDAG) Selection.TypeText Text:="Langfredag" WordBasic.WordLeft 2
Case Helligdag(CInt(aar), PÅSKEDAG) Selection.TypeText Text:="Påskedag" WordBasic.WordLeft 2
Case Helligdag(CInt(aar), PÅSKEDAG2) Selection.TypeText Text:="2. Påskedag" WordBasic.WordLeft 4
Case Helligdag(CInt(aar), BEDEDAG) Selection.TypeText Text:="St.Bededag" WordBasic.WordLeft 4
Case Helligdag(CInt(aar), KRISTIHIMMELFARTSDAG) Selection.TypeText Text:="Kr.himmelfartsdag" WordBasic.WordLeft 4
Case Helligdag(CInt(aar), PINSEDAG) Selection.TypeText Text:="Pinsedag" WordBasic.WordLeft 2
Case Helligdag(CInt(aar), PINSEDAG2) Selection.TypeText Text:="2. Pinsedag" WordBasic.WordLeft 4
Case Else
If (Month(dtmDate) = 1) And (Day(dtmDate) = 1) Then Selection.TypeText Text:="Nytårsdag" ElseIf (Month(dtmDate) = 5) And (Day(dtmDate) = 1) Then Selection.TypeText Text:="1. Maj" ElseIf (Month(dtmDate) = 6) And (Day(dtmDate) = 5) Then Selection.TypeText Text:="Grundlovsdag" ElseIf (Month(dtmDate) = 12) And (Day(dtmDate) = 25) Then Selection.TypeText Text:="Juledag" ElseIf (Month(dtmDate) = 12) And (Day(dtmDate) = 26) Then Selection.TypeText Text:="2. Juledag" End If WordBasic.WordLeft 4
End Select
End If
Select Case WordBasic.Weekday(datosn) Case SØNDAG WordBasic.ShadingPattern 4 WordBasic.CharRight 1 Selection.Font.Size = 8 Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter WordBasic.ShadingPattern 4 WordBasic.WordLeft 1
Case MANDAG If Not IsHelligdag(DateSerial(aar, maaned, dag)) Then
WordBasic.Wordright 1 WordBasic.TableSplitCells NumColumns:="2" WordBasic.NextCell WordBasic.CharRight 1, 1 WordBasic.NextCell Selection.ParagraphFormat.Alignment = wdAlignParagraphRight Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter Selection.Font.Color = wdColorBlack Selection.Font.Size = 8 WordBasic.Insert Trim(Str(WEEKNR(Str(datosn)))) WordBasic.TableSelectCell Right = Selection.Cells.Width WordBasic.PrevCell WordBasic.TableSelectCell Left = Selection.Cells.Width Wide = Left + Right Left = Wide - 20 Right = 20 Selection.Cells.Width = Left WordBasic.NextCell WordBasic.TableSelectCell Selection.Cells.Width = Right Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone With Selection.Borders(wdBorderRight) .LineStyle = Options.DefaultBorderLineStyle .LineWidth = Options.DefaultBorderLineWidth .Color = Options.DefaultBorderColor End With
WordBasic.WordLeft 4 End If
Case LØRDAG WordBasic.ShadingPattern 4
Case Else
End Select
WordBasic.LineDown 1 datosn = datosn + 1 dag = dag + 1 maaned = WordBasic.Month(datosn) Wend
I lang tid har samarbejdsbranchen fokuseret på at forbedre enhedsfunktioner – bedre kameraer, klarere lyd og smartere software. Men den virkelige forvandling handler ikke om funktioner.
Kopier hele teksten nedenfor til et modul og kald makroen 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 = "Juleaftensdag" 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", "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.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
Fra nyt tomt excel ark: Tryk på Alt + F11 VBA editoren åbner I menuen [Insert] - tryk på [Module] Editoren indsætter et modul, sikkert med navnet Module1 I dette modul indsætter du ovenstående kode og lukker VBA editoren igen I det tomme ark vælger du nu [Funktioner] - [Makro] - [Makroer] (eller tryk på Alt + F8) Der finder du en makro der hedder Kalender - Afspil den og den spørger dig hvilket år du vil lave kalender for. Når du har svaret, f.eks. 2007, opretter den en kalender for 1 år komplet med helligdage. Koden er givet flere gange herinde på Eksperten. Gad vide om nogen husker hvor den kommer fra?
Jeg har en anden version af kalenderen hvor koden er meget kortere, bl.a. fordi koden ikke formaterer en kalender. Den er formateret direkte på arket. I den kan det godt lade sig gøre at Lørdag kun er delvist gråtonet. Jeg kan sende dig den.
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 = "Juleaftensdag" 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", "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.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 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 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
Dejligt at se nogen der bruger min kode, jeg har ændret i den, så den skulle vist svare til spørgsmålet om lørdage og søndage.
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 = "Juleaftensdag" 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", "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.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 Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15 Case 2 Cells(i, k + 2) = "" Cells(i, k + 2) = DatePart("ww", Dato, vbMonday, vbFirstFourDays) & " " & HD Case 7 Range(Cells(i, k), Cells(i, k + 1)).Interior.ColorIndex = 15 End Select Cells(i, k + 2) = HD If HD <> "" Then Cells(i, k + 2).Interior.ColorIndex = 40 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 = 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 Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15 Case 2 Cells(i, k + 2) = "" Cells(i, k + 2) = DatePart("ww", Dato, vbMonday, vbFirstFourDays) & " " & HD Case 7 Range(Cells(i, k), Cells(i, k + 1)).Interior.ColorIndex = 15 End Select Cells(i, k + 2) = HD If HD <> "" Then Cells(i, k + 2).Interior.ColorIndex = 40 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
x-lars > det var dig der hjalp, så selvfølgelig skal du have dem, jeg rettede bare lige lidt til sidst. Selvom jeg har lavet det engeng, har jeg absolut ikke noget imod at andre får point, ved at henvise, eller sætte koden ind.
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 = "Juleaftensdag" 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", "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.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 Cells(i, k + 2) = HD Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15 Case 2 Cells(i, k + 2) = HD & Space((15 - Len(HD)) * 1.2) & DatePart("ww", Dato, vbMonday, vbFirstFourDays) Case 7 Range(Cells(i, k), Cells(i, k + 1)).Interior.ColorIndex = 15 Case Else Cells(i, k + 2) = HD End Select If HD <> "" Then Cells(i, k + 2).Interior.ColorIndex = 40 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 = 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 Cells(i, k + 2) = HD Range(Cells(i, k), Cells(i, k + 2)).Interior.ColorIndex = 15 Case 2 Cells(i, k + 2) = HD & Space((15 - Len(HD)) * 1.2) & DatePart("ww", Dato, vbMonday, vbFirstFourDays) Case 7 Range(Cells(i, k), Cells(i, k + 1)).Interior.ColorIndex = 15 Case Else Cells(i, k + 2) = HD End Select
If HD <> "" Then Cells(i, k + 2).Interior.ColorIndex = 40 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
PS: Skal du alligevel udfordres lidt? Ugenr. kunne jo stå som vandmærke midt i ugefeltet, du véd, med stor skrift.
Synes godt om
Ny brugerNybegynder
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.
