Kode til beregning af søn- og helligdage

der er en funktion til ugedag
hvis den giver 6 er det lørdag, 7 hvis det er søndag
=UGEDAG(B1;2)

Public Sub Dato()
Dim Dato As String, D As Integer
Dato = InputBox(" indtast dato")
D = Weekday(Dato, vbMonday)
Select Case D
Case 1
dagen = "Mandag"
Case 2
dagen = "Tirsdag"
Case 3
dagen = "Onsdag"
Case 4
dagen = "Torsdag"
Case 5
dagen = "Fredag"
Case 6
dagen = "Lørdag"
Case 7
dagen = "Søndag"
End Select
MsgBox " dagen er en " & dagen
End Sub

men det giver ikke de skæve helligdage, måske kan de stjæles fra Outlook, som jo har dem.

http://www.folkekirken.dk/downloads2/kalender.xls

Her er kirkens kalender på regneark

Husk lige 1.maj, 5.juni, 24.december og 31.december

jeg havde en fix og færdig liggende som dyret fik, andre int. kan maile til ullum@mail.dk

Point fordelt efter brugbarhed. Kabbak fik en smule for linket til folkekirken - eller så mistede gollum lidt for at kalde mig dyret... ;)

Hmm nå det er prisen, jeg sad ellers og tænkte på vilddyret, men nej nej

Denne funktion kan beregne om en given dato er en søn- eller helligdag.
skriv en dato i fx. A1 og i B2 skriv
=Isholiday(A1;Falsk;Sand)

Hvis dagen er søn/helligdag returneres Sand ellers falsk.

Function EasterSunday(InputYear As Integer) As Long
' Returns the date for Easter Sunday, does not depend on Excel
Dim d As Integer
    d = (((255 - 11 * (InputYear Mod 19)) - 21) Mod 30) + 21
    EasterSunday = DateSerial(InputYear, 3, 1) + d + (d > 48) + 6 - _
        ((InputYear + InputYear \ 4 + d + (d > 48) + 1) Mod 7)
End Function


Function IsHoliday(lngDate As Long, InclSaturdays As Boolean, _
    InclSundays As Boolean) As Boolean
' returns True if lngDate is a Norwegian holiday
' (optionally included Saturdays/Sundays)
' benytter funksjonen EasterSunday
Dim InputYear As Integer, ES As Long, OK As Boolean
    If lngDate <= 0 Then lngDate = Date
    InputYear = Year(lngDate)
    ES = EasterSunday(InputYear)
    OK = True
    Select Case lngDate
        Case DateSerial(InputYear, 1, 1) ' 1. Nyttårsdag
        'Case ES - 4 ' Onsdag før påske
        Case ES - 3 ' Skjærtorsdag
        Case ES - 2 ' Langfredag
        Case ES ' 1. Påskedag
        Case ES + 1 ' 2. Påskedag
        Case DateSerial(InputYear, 5, 1) ' 1. mai
        Case DateSerial(InputYear, 5, 17) ' 17. mai
        Case ES + 39 ' Kristi Himmelfartsdag
        'Case ES + 48 ' Pinseaften
        Case ES + 49 ' 1. Pinsedag
        Case ES + 50 ' 2. Pinsedag
        'Case DateSerial(InputYear, 12, 24) ' Julaften
        Case DateSerial(InputYear, 12, 25) ' 1. Juledag
        Case DateSerial(InputYear, 12, 26) ' 2. Juledag
        'Case DateSerial(InputYear, 12, 31) ' Nytårsaften
        Case Else
            OK = False
            If InclSaturdays Then
                If Weekday(lngDate, vbMonday) = 6 Then
                    OK = True
                End If
            End If
            If InclSundays Then
                If Weekday(lngDate, vbMonday) = 7 Then
                    OK = True
                End If
            End If
    End Select
    IsHoliday = OK
End Function

ps. hentet direkte fra http://www.erlandsendata.no/english/functions/

Jeg var også helt forundret over, hvorfor der ikke kom et indlæg fra din side, bak! Men så viser det sig jo, at du har været ude og finde det helt rigtige! En skam, at point lige var nået at blive delt ud...

Det er ok med de points, jeg har nok :-)
Faktisk havde jeg selv lavet en kode, men manglede lige påskeberegningen og ville finde den på nettet.
Da jeg så opdagede at at en rigtig profi havde lavet alt i forvejen,var der ligesom ingen grund til at fortsætte med min kode.....

hvordan skal VBA kald datoen se ud til Isholiday

Sub TESTKALD()
Dim m As Long
m = CDate("24/12/2006")
Debug.Print IsHoliday(m, True, True)
End Sub

nedenstående kode skal ændres til at ugenr altid skrives helt til højre om mandagen og ligeledes at der kan skrives i feltet selvom ugenumret står der ?



Const SØNDAG = 1
Const MANDAG = 2
Const LØRDAG = 7
Const SKÆRTORSDAG = 1
Const LANGFREDAG = 2
Const PÅSKEDAG = 3
Const PÅSKEDAG2 = 4 ' 2. påskedag
Const BEDEDAG = 5
Const KRISTIHIMMELFARTSDAG = 6
Const PINSEDAG = 7
Const PINSEDAG2 = 8 ' 2. pinsedag

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

    intYear = Year(dtmDate)
    dtmPåskedag = glrPåskedag(intYear)

    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 datolr
Dim dmaaned
Dim temp

ReDim dage__$(7)
dage__$(1) = "S ": dage__$(2) = "M ": dage__$(3) = "T "
dage__$(4) = "O ": dage__$(5) = "T "
dage__$(6) = "F ": dage__$(7) = "L "

ReDim mdr__$(12)
mdr__$(1) = "Januar": mdr__$(2) = "Februar": mdr__$(3) = "Marts"
mdr__$(4) = "April": mdr__$(5) = "Maj": mdr__$(6) = "Juni"
mdr__$(7) = "Juli": mdr__$(8) = "August": mdr__$(9) = "September"
mdr__$(10) = "Oktober": mdr__$(11) = "November": mdr__$(12) = "December"

WordBasic.BeginDialog 630, 122, "Opretter kalender"
    WordBasic.TextBox 305, 24, 160, 18, "kalendernavn$"
    WordBasic.Text 10, 28, 213, 13, "Navnet på kalenderen:", "Tekst1"
   
    WordBasic.TextBox 305, 48, 160, 18, "mdnr$"
    WordBasic.Text 10, 52, 213, 13, "Nummeret på den 1. måned:", "Tekst2"
   
    WordBasic.TextBox 305, 72, 160, 18, "aar$"
    WordBasic.Text 10, 76, 268, 13, "Årstallet, hvor den første måned er:", "Tekst3"
   
    WordBasic.TextBox 305, 96, 160, 18, "antal$"
    WordBasic.Text 10, 100, 115, 13, "Antal måneder:", "Tekst4"
   
    WordBasic.OKButton 521, 21, 88, 21
    WordBasic.CancelButton 521, 48, 88, 21
WordBasic.EndDialog

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



WordBasic.Bold 1
WordBasic.Insert informationer.kalendernavn$

WordBasic.TableInsertTable ConvertFrom:="", NumColumns:=Str(WordBasic.Val(informationer.antal$) * 2), NumRows:="33", InitialColWidth:="Auto", Format:="16", Apply:="1"

maaned = WordBasic.Val(informationer.mdnr$)
aar = WordBasic.Val(informationer.aar$)


For teller = 1 To WordBasic.Val(informationer.antal$)
   
    WordBasic.TableSelectColumn
    WordBasic.TableColumnWidth ColumnWidth:="1,5 cm", RulerStyle:="2"
    WordBasic.CharLeft 1
    WordBasic.CharRight 2, 1
    WordBasic.TableMergeCells
    WordBasic.CharLeft 1
    WordBasic.EditBookmark Name:="her", SortBy:=0, Add:=1
   
    WordBasic.Bold 1
    WordBasic.Insert Str(aar)
    WordBasic.Bold 0
    WordBasic.WordLeft 1
    WordBasic.LineDown 1
    WordBasic.CharRight 2, 1
    WordBasic.TableMergeCells
   
   
    WordBasic.ShadingPattern 6
    WordBasic.Bold 1
    WordBasic.Insert mdr__$(maaned)
   
    WordBasic.Bold 0
    WordBasic.WordLeft 1
    WordBasic.LineDown 1
    dag = 1
    datosn = WordBasic.DateSerial(aar, maaned, dag)
   
   
       
    dmaaned = maaned
    While dmaaned = maaned
       
       
        WordBasic.Insert dage__$(WordBasic.Weekday(datosn))
        WordBasic.FormatTabs Position:="1,1 cm", Align:=2, Leader:=0, Set:=1
        WordBasic.Insert Chr(9)
        WordBasic.Insert Str(WordBasic.Day(datosn))
        WordBasic.BorderRight 0
   
             
        WordBasic.WordRight 1
     
        Selection.Font.Bold = wdToggle
        Selection.Font.Size = 8
        Selection.Font.Color = wdColorBlue
       
        WordBasic.WordLeft 1
       
        dtmDate = DateSerial(aar, maaned, dag)
           
        If IsHelligdag(DateSerial(aar, maaned, dag)) Then
          WordBasic.ShadingPattern 4
          WordBasic.WordRight 1
         
           
          Selection.Font.Italic = wdToggle
          Selection.Font.Color = wdColorBlack
          Selection.Font.Size = 8
         
          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
         
          Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
         
          Select Case DateSerial(aar, maaned, dag)
                         
            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
               
                WordBasic.ShadingPattern 4
                WordBasic.WordLeft 1
               
            Case MANDAG
                If Not IsHelligdag(DateSerial(aar, maaned, dag)) Then
                    WordBasic.WordRight 1
                    Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
                    Selection.Font.Color = wdColorBlack
                    WordBasic.Insert Str(WEEKNR(Str(datosn)))
                 
                    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

    temp = WordBasic.Day(datosn)

    While temp <= 30
        WordBasic.BorderRight 0
        WordBasic.LineDown 1
        temp = temp + 1
    Wend

    WordBasic.EditBookmark Name:="her", SortBy:=0, GoTo:=1
    WordBasic.CenterPara
    WordBasic.LineDown 1
    WordBasic.CenterPara
    WordBasic.EditBookmark Name:="her", SortBy:=0, GoTo:=1
    WordBasic.BorderBottom 0
    WordBasic.NextCell
    aar = WordBasic.Year(datosn)
Next teller

WordBasic.StartOfDocument

GoTo slut

fejl:
WordBasic.MsgBox errtext$
GoTo start

slut:

End Sub