Kalender - ugenumre - formatering hvordan?

er rettet her

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))
Cells(I, K + 2).Font.Bold = False 'NY sletter evt. gamle med fed
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
    Cells(I, K + 2).Characters(Start:=1, Length:=2).Font.Bold = True 'NY de 2 første fed

  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))
Cells(I, K + 2).Font.Bold = False 'NY sletter evt. gamle med fed
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
  Cells(I, K + 2).Characters(Start:=1, Length:=2).Font.Bold = True 'NY de 2 første fed
  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

http://j-walk.com/ss/excel/files/developer.htm
http://www.erlandsendata.no/norsk/
http://www.hcma.dk/
http://www.exceltip.com/

Jeg har lavet en 12 måneders kalender med som fungere udelukkende ved hjælpe af formler og betinget formatering.

Er lavet så den ligner en af de alm. reklame kalender med ½ år side, har dog tilføjet nogle flere kolonner, så det blev til 3 mdr. pr. side.

Virker kanon, bruger den som "familie" kalender til opslagstavlen

I hver måend har jeg 6 kolonner

Ugedag
dato
Uge nr. (står kun ud for mandag)
Forældre
barn 1
Barn 2

Ved at ændre årstal i A1 skifter de 3 første kolonner og hele formatteringen ændres så aut. Rammer om uge/måneder.

I tabeller neden under har jeg stående de alm. helligedage, fødselsdage mv., og kan desuden tilføje andre aftaler (max 1 dag / kolonne (forældre/barn 1/barn 2).)

Disse aftaler bliver så hentet op i kalenderen vha. lookup.


Har desværre ingen hjemmeside hvor jeg kan ligge den ud, men hvis du ligger en mail adresse kan jeg maile dig en version hvor jeg har slettet alt undtagen helligedage.

Hold da op et stykke kode! er det ikke meget nemmere at lave det vha. af formler/betinget formatering.

Katborg >

Ja, der er noget kode.

min finder også påskedagene, kan du det. ?

Hvad med dine ugenr. passer de i år, hvis du bruger funktionen UGE.NR( dato), så passer den ikke.


Men jeg vil da gerne se din ;-)

Jeg bruger ikke UGE.NR(dato), har "lånt" en formel herfra - måske der det din ?

=INT((B4-(DATE(YEAR(B4+(MOD(8-WEEKDAY(B4);7)-3));1;1))-3+MOD(WEEKDAY(DATE(YEAR(B4+(MOD(8-WEEKDAY(B4);7)-3));1;1))+1;7))/7)+1

Og jeg kan godt se at din macro selv finder påskedage mv, den er jeg lige igang med at konvertere til excel formel.

Hvor har du den formel/funktion fra ?

http://www.exceltip.com/st/Calculate_holidays_using_VBA_in_Microsoft_Excel/522.html

og prøv at se her

http://www.google.com/search?q=p%C3%A5skedag+excel&hl=da&lr=lang_da&start=10&sa=N

Jeps, det lykkedes vha en formel, så kan jeg få den arbejder in min formel kalender :-)

Year = B1
d    = B2 = MOD((255-11*MOD(B1;19))-21;30)+21

Påskesøndag = =DATE(B1;3;1)+B2+MAX(B2-48;0)+6-ROUNDDOWN(MOD(B1+B1/4+B2+MAX(B2-48;0)+1;7);0)

Har test det fra 1999 -> 2013, kontrollet med "kalendergenerator.xls", som dit link henviste til

Eller lagt sammen i en celle

Year = A1
=DATE(A1;3;1)+(MOD((255-11*MOD(A1;19))-21;30)+21)+MAX((MOD((255-11*MOD(A1;19))-21;30)+21)-48;0)+6-ROUNDDOWN(MOD(A1+A1/4+(MOD((255-11*MOD(A1;19))-21;30)+21)+MAX((MOD((255-11*MOD(A1;19))-21;30)+21)-48;0)+1;7);0)

Så nu er min kalender fuldautomatisk.

Skriv årstallet i A1, så rettes ugedag, uge nr og arket formateres med rammer omkring uge. og! helligedage ligges nu ligeledes aut. ind.

Før havde jeg lavet en lille tabel med det, men formlen er lidt mere sej!

Tak for inspirationen kabbak! :-)

Har tidligere redigeret en kalender (oprindelig lavet af en der kalder sig SHM) hvor jeg i øvrigt fik megen hjælp af kabbak. Jeg har lavet en version der skrives ud på 2 ark  med ½ år på hvert ark (liggende), en version med 1 kvt. på hvert ark (stående) samt en lille til at foldes og stikke ind i omslaget på en spiralkalender.
Vil gerne sende den hvis nogen er interesseret.
Ugenumre er selvfølgelig også med.

>katborg, Jeg vil gerne have en kopi af din kalender

laurbjerg@vip.cybercity.dk

>kabbak. Endnu en gang mange tak. Ja, jeg måtte strække våben - der skal jo ikke være mange fejl i koden, før det går galt. Men jeg fik da ændret nogle farver på egen hånd :-)   
>katborg og perhol. Tak for input! Sikke en hjælpsomhed i dette forum.  Kan I ikke lægge jeres løsninger ud her? Vi er sikkert mange newbies, der har udbytte af at se, hvordan de forskellige løsninger er skruet sammen :-).

>ber
Hvordan ligger man 1 excel fil ind her ?

>katborg
Kabbak har en vejledning i http://eksperten.dk/spm/505331 - det er makroen i din kalenderfil, du kan lægge ud.
>kabbak og brugere:
:-) Julaftensdag -> Juleaftensdag.

>ber

Jeg har ingen makro i min kalenderfil, den fungere udelukkende vha af formler og betinget formatering.

Min kalender består af et i forvejen formateret ark hvor man så ændrer årstal 1 sted og derefter kører en makro der er lagt i et modul.
Jeg kan sende den, men har desværre ingen hjemmeside hvor jeg kan lægge den.
Generer det dig at lægge din mailadresse her?
Min er "perhol at webspeed dot dk"

>katborg - jeg har læst som fanden læser bibelen. Pardon. Du har brugt formler m.v., så det lader sig ikke gøre at lægge den ud.
>perhol - det var nu mere for at gøre det tilgængeligt for andre brugere her på sitet, så ...
Jeg har jo nu kabbak's udmærkede kalender og vil gerne fortsætte med makroer i VBA.
Men, tak anyway :-)