02. juni 2004 - 19:11Der er
27 kommentarer og 1 løsning
Oversigtskalender som de trykte - skabelon
Hej eksperter,
Jeg er på jagt efter en oversigtskalender i lighed med de trykte, f.eks. fra Maylands. Jeg skal kunne lægge min vagtplan ind til orientering for venner og familie. Derfor skal den også kunne printes, f.eks. med oversigt over et kvartal.
Arbejder i Office 2000 og kan ikke umiddelbart finde noget brugbart. Nogen der kan hjælpe?
-> Susanne. Har tidligere kigget på MS WORD-skabelonerne, men det skulle gerne være en kalender, jeg ikke behøver at lave fra grunden næste gang. Men overskueligheden ligger der. Fint nok.
Har prøvet andre kalenderprogrammer, men vil gerne lave en uden clipart m.v. og i helt rent design ... måske leder jeg efter den helt rigtige skabelon - lige til at gå til. Men tak for input, Susanne.
Det er ret pudsigt :-). Jeg har tidligere i dag fundet Henry og downloadet årskalenderen. For det er netop lige den jeg søger! Men makroen?? Det er jeg ikke nogen ørn til. Kan du hjælpe? - henry's mail-adresse virker ikke (mere), har prøvet at få et tip derfra.
Formentlig ikke, men jeg plejer at blive 'spurgt' (popup), når jeg bruger andre Excel-ark, der indeholder makroer - jeg har 'altid' haft indstillingen høj uden problemer. Stor tak herfra. Nu kan alle (osse dem uden skærm) få et godt overblik. /ber
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 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 Range("I1") = År 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) Cells(I, K) = Dag(Weekday(Dato)) Select Case Weekday(Dato) Case 1, 7 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) & " " & HelligdagsNavn(DD) Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Case Else Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Cells(I, K + 2) = HelligdagsNavn(DD) End Select Cells(I, K + 1) = Day(Dato) 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) Cells(I, K) = Dag(Weekday(Dato)) Select Case Weekday(Dato) Case 1, 7 Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 15 Case 2
Cells(I, K + 2) = "'" & DatePart("ww", Dato, vbMonday, vbFirstFourDays) & " " & HelligdagsNavn(DD) Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Case Else Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Cells(I, K + 2) = HelligdagsNavn(DD) End Select 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").Select Range("R1").Activate Selection.ColumnWidth = 10 ActiveSheet.PageSetup.PrintArea = "$A$1:$R$65" With ActiveSheet.PageSetup .FitToPagesWide = 1 .FitToPagesTall = 1 End With 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
jeg var lidt for hurtig, der røg nogen helligdage.
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 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 Range("I1") = År 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) 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) = HelligdagsNavn(DD) Case 2 Cells(I, K + 2) = "" Cells(I, K + 2) = "'" & DatePart("ww", Dato, vbMonday, vbFirstFourDays) & " " & HelligdagsNavn(DD) Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Case Else Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Cells(I, K + 2) = HelligdagsNavn(DD) End Select Cells(I, K + 1) = Day(Dato) 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) 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) = HelligdagsNavn(DD) Case 2
Cells(I, K + 2) = "'" & DatePart("ww", Dato, vbMonday, vbFirstFourDays) & " " & HelligdagsNavn(DD) Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Case Else Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Cells(I, K + 2) = HelligdagsNavn(DD) End Select 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").Select Range("R1").Activate Selection.ColumnWidth = 10 ActiveSheet.PageSetup.PrintArea = "$A$1:$R$65" With ActiveSheet.PageSetup .FitToPagesWide = 1 .FitToPagesTall = 1 End With 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
Mageløst! Mange tak - jeg prøver i weekenden. Ser rigtigt spændende ud og viser bare, hvorfor jeg ikke selv gav mig i kast med sagen!! Henry's kalender blev ellers fin. Og Excel-indstillingerne er ikke sat til høj igen. Tak for dét tip osse.:-)
Lavet lidt flere ændringer, helligdage uden for lørdag og søndag, bliver farvet og lavet 2 sidet liggende udskrift.
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 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 = 10 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
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.
Ny bruger
Nybegynder
Opret
Preview
