23. november 2005 - 20:50Der er
15 kommentarer og 3 løsninger
Celler skal være grå hvis helligdage.
Okay, lad os tage den helt fra starten: Jeg har et regneark med 12 forskellige ark - én kalendermåned på hvert ark. Det er sådan set ikke kalendermåneden jeg har problemer med. Jeg har allerede fået gjort kalenderen dynamisk, d.v.s. at den bliver genereret automatisk med datoer og ugedage, så snart jeg har indtastet f.eks. "01-01-2006" i A1 på ark1. Derudover har jeg - v.hj.a. betinget formatering - gjort celler, som er lør- eller søndag til grå. Celleopbygningen ser således ud:
A1 = "01-01-2006" (Start)
B7-B37 = Ugedag C7-C37 = Dato D7-D37 = Arbejdstid start E7-E37 = Arbejdstid slut F7-F37 = Antal timer (sum)
Når jeg nu gerne vil lave en ny kalender - og her kommer problemet så - vil jeg gerne, at cellerne (ugedag/dato/arbejdstid start/arbejdstid slut) bliver grå, hvis aktuelle dag falder på en helligdag eller lør-/søndag. Det med lør- og søndag har jeg sådan set allerede v.hj.a. den betingede formatering, men det med helligdagene kniber det altså med!
Jeg har allerede ledt her på sitet for hjælp, men kan nu ikke lige få noget til at passe ind i mit problem!
Håber der er nogen, som kan hjælpe med opgaven her?
PS. Da jeg ved, at det nok er en meget svær opgave og jeg vil stille mange spørgsmål (hvis ellers nogen kan hjælpe) har jeg sat points til 200 (meget svært).
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
du kalder HelligdagsNavn(lngdate As Long) den retunerer helligdagen lngdate As Long , er datoen
Prøv med denne her. Den returnerer true, hvis datoen er en helligdag:
Function ErHelligdag(testDato As Long, InclLørdage As Boolean, InclSøndage As Boolean) As Boolean Dim InputYear As Integer, PD As Long, OK As Boolean If testDato <= 0 Then testDato = Date InputYear = Year(testDato) PD = Påskedag(InputYear) OK = True Select Case testDato Case DateSerial(InputYear, 1, 1) ' Nytårsdag Case PD - 7 ' Palmesøndag Case PD - 3 ' Skærtorsdag Case PD - 2 ' Langfredag Case PD ' Påskedag Case PD + 1 ' 2. påskedag Case PD + 26 ' St. Bededag Case PD + 39 ' Kristi Himmelfartsdag Case PD + 49 ' Pinsedag Case PD + 50 ' 2. Pinsedag Case DateSerial(InputYear, 12, 24) ' Juleaftensdag Case DateSerial(InputYear, 12, 25) ' Juledag Case DateSerial(InputYear, 12, 26) ' 2. Juledag Case DateSerial(InputYear, 12, 31) ' Nytårsaftensdag Case Else OK = False If InclLørdage Then If WeekDay(testDato, vbMonday) = 6 Then OK = True End If End If If InclSøndage Then If WeekDay(testDato, vbMonday) = 7 Then OK = True End If End If End Select IsHoliday = OK End Function
Function Påskedag(InputYear As Integer) As Long 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
Hmmm.... hvis jeg bruger kabbaks forslag, så vil navnet på helligdagen blive vist i de felter, hvor jeg bruger funktionen. Problemet er, at jeg allerede HAR noget i de felter, hvor helligdagen skal vises. Den skal bare ikke vises med navnet på dagen, men derimod farve cellerne grå. I øvrigt står der bare "#VÆRDI" i cellerne, hvor der i den pågældende måned ikke er en dato, f.eks. 29-02-2007 (datoen eksisterer ikke).
Prøver jeg sjap's forslag, så sker der intet, men får altså heller ingen fejl, såsom "#VÆRDI" i cellerne. Måske virker det, men jeg skal bare have cellerne til at blive grå, hvis det er en helligdag eller lør-/søndag?
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
kabbak -> jeg har før set din kalender herinde, men jeg kan slet ikke gennemskue din VB kode.
Ad 23:22 Du spørger om du må se min del af koden. Jeg har ingen anden kode, end den jeg forhåbentlig får fat i herinde! Min kalender er mere eller mindre manuelt oprettet på forhånd.
Nuvel, sjap's forslag returnerer ganske vist enten "SAND" eller "FALSK", men hvordan får jeg nu de celler til at være grå i stedet for hvis, hvis den returnerer "SAND"?
Sub farvCeller() For Each C In Range("C7:C37").Cells If ErHelligdag(C.Value, 1, 1) Then C.Interior.ColorIndex = 15 Else C.Interior.ColorIndex = xlNone End If Next End Sub
Function ErHelligdag(testDato As Long, InclLørdage As Boolean, InclSøndage As Boolean) As Boolean Dim InputYear As Integer, PD As Long, OK As Boolean If testDato <= 0 Then testDato = Date InputYear = Year(testDato) PD = Påskedag(InputYear) OK = True Select Case testDato Case DateSerial(InputYear, 1, 1) ' Nytårsdag Case PD - 7 ' Palmesøndag Case PD - 3 ' Skærtorsdag Case PD - 2 ' Langfredag Case PD ' Påskedag Case PD + 1 ' 2. påskedag Case PD + 26 ' St. Bededag Case PD + 39 ' Kristi Himmelfartsdag Case PD + 49 ' Pinsedag Case PD + 50 ' 2. Pinsedag Case DateSerial(InputYear, 12, 24) ' Juleaftensdag Case DateSerial(InputYear, 12, 25) ' Juledag Case DateSerial(InputYear, 12, 26) ' 2. Juledag Case DateSerial(InputYear, 12, 31) ' Nytårsaftensdag Case Else OK = False If InclLørdage Then If Weekday(testDato, vbMonday) = 6 Then OK = True End If End If If InclSøndage Then If Weekday(testDato, vbMonday) = 7 Then OK = True End If End If End Select ErHelligdag = OK End Function
Function Påskedag(InputYear As Integer) As Long 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
Brug betinget formatering og vælg "Formel er" og indsæt =erhelligdag(A1;SAND;SAND) hvis det er A1 og vælg så en grå farve Kopier denne formatering henover alle de andre celler med formatpenslen
-> bak, uden dit kommentar 00:06:02 med betinget formatering, var jeg aldrig blevet færdig med det her; derfor synes jeg bestemt, du har fortjent pts. også! Jeg fordeler, når sjap også har afgivet svar!
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.
