Jeg har fundet en programkode på en kalender der køres med en makro, kalenderen virker stort set rigtig godt, men der er blot en enkelt fejl i kalenderen, og som jeg vil høre jer om, om i kan hjælpe mig med.
Fejlen ligger i februar måned d. 29, i de årstal hvor der er skudår er den god nok, men de øvrige 3 år imellem er d. 29 med og med forkert dag angivet.
Kan man slette / rette denne fejl ?
indsætter lige koden her.
Glæder mig til at høre fra jer.
Timer.
Programkode:
Åben et tomt regneark, højreklik på arknavn (i bunden), vælg vis programkode, indsæt nedenstående kode i visual basic, vend tilbage til arket, tryk alt+f8, vælg "Afspil", du skulle nu kunne vælge årstal for den ønskede 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 = "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 Range("A3:R33").Font.ColorIndex = xlAutomatic Range("A35:R65").Font.ColorIndex = xlAutomatic 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
Cells(I, K + 2).Font.ColorIndex = xlAutomatic If IsNumeric(Left(Cells(I, K + 2).Value, 1)) And IsNumeric(Mid(Cells(I, K + 2).Value, 1, 1)) Then Cells(I, K + 2).Characters(Start:=1, Length:=2).Font.ColorIndex = 5 Else Cells(I, K + 2).Characters(Start:=1, Length:=1).Font.ColorIndex = 5 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 Cells(I, K + 2).Font.ColorIndex = xlAutomatic If IsNumeric(Left(Cells(I, K + 2).Value, 1)) And IsNumeric(Mid(Cells(I, K + 2).Value, 1, 1)) Then Cells(I, K + 2).Characters(Start:=1, Length:=2).Font.ColorIndex = 5 Else Cells(I, K + 2).Characters(Start:=1, Length:=1).Font.ColorIndex = 5 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
Jeg kan se, at det er mine gamle Påskedag og Helligdags funktioner, der er i brug her Dem har jeg ikke set siden slutningen af 1990'erne!
Ja, det var sådan jeg gjorde dengang, hvor jeg var ny og grøn ud i VBA-kode - der er godt nok løbet meget vand under broen siden I dag er funktionerne langt mere fleksible og brugbare - for ikke, at snakke om mere professionelt opbyggede - måske jeg skulle smide dem ud på mit website igen???
Anyway, prøv, at uploade dit regneark til forummet, og jeg skal prøve, at tage et kig på det...
Husk, at trykke på [Tak], hvis du kan lide et indlæg. Husk, at trykke på [Accepteret Svar], hvis du kan bruge et løsningsforslag.
Du kan ikke oprette nye emner i dette forum Du kan ikke besvare beskeder i dette forum Du kan ikke slette dine beskeder i dette forum Du kan ikke redigere dine beskeder i dette forum Du kan ikke oprette afstemninger i dette forum Du kan ikke stemme i dette forum