Access 2010 Abfrage erster Werktag

Option Compare Database

Option Explicit
'// ----------------------------------------------------------------  
'// Feiertagsberechnung nach dem Algorithmus von Carl Friedrich Gauß  
'// ----------------------------------------------------------------  
Type AtFeiertage
     Jahreszahl         As Long
     Ostern             As Date
     Neujahr            As Date
     DreiKoenige        As Date
    'Rosenmontag        As Date  
    'Aschermittwoch     As Date  
    'Karfreitag         As Date  
     Ostersonntag       As Date
     Ostermontag        As Date
     Maifeiertag        As Date
     ChrHimmelfahrt     As Date
     Pfingstsonntag     As Date
     Pfingstmontag      As Date
     Fronleichnam       As Date
     MariaeHimmelfahrt  As Date
     Nation             As Date
    'Reformationstag    As Date  
     Allerheiligen      As Date
    'Heiligabend        As Date  
     Weihnachten1       As Date
     Weihnachten2       As Date
    'Sylvester          As Date  
End Type
 
Dim m_uDTF As AtFeiertage
'Dim x As String  

 
 
Public Function Feiertag(mdatum As Date, FeiertagsName As String) As Integer
 
   Dim Jahreszahl As Integer
   Dim mbol As Integer
   
   Jahreszahl = DatePart("yyyy", mdatum)  
    
   mbol = 0

'// Als Refrenzdatum zunächst m_uDTF.Ostern berechnen  
    If Not Ostern_berechnen(Jahreszahl) Then Exit Function
    
'// Neujahr setzen (fester Feiertag am 1. Januar)  
    m_uDTF.Neujahr = DateSerial(Jahreszahl, 1, 1)
    If mdatum = m_uDTF.Neujahr Then mbol = 1: FeiertagsName = "Neujahr"  
   
'// Hl. Drei Könige setzen (fester Feiertag am 6. Januar)  
    m_uDTF.DreiKoenige = DateSerial(Jahreszahl, 1, 6)
    If mdatum = m_uDTF.DreiKoenige Then mbol = 1: FeiertagsName = "Hl. Drei Koenige"  
 
'// Rosenmontag berechnen (beweglicher Feiertag; 48 Tage vor Ostern)  
'// m_uDTF.Rosenmontag = m_uDTF.Ostern - 48  
'// If mdatum = m_uDTF.Rosenmontag Then mbol = True: FeiertagsName = "Rosenmontag"  
 
'// Aschemittwoch berechnen (beweglicher Feiertag; 46 Tage vor Ostern)  
'// m_uDTF.Aschermittwoch = m_uDTF.Ostern - 46  
'// If mdatum = m_uDTF.Aschermittwoch Then mbol = True: FeiertagsName = "Aschermittwoch"  
 
'// Karfreitag berechnen (beweglicher Feiertag; 2 Tage vor Ostern)  
'// m_uDTF.Karfreitag = m_uDTF.Ostern - 2  
'// If mdatum = m_uDTF.Karfreitag Then mbol = True: FeiertagsName = "Karfreitag"  
 
'// Ostersonntag = m_uDTF.Ostern!  
    m_uDTF.Ostersonntag = m_uDTF.Ostern
    If mdatum = m_uDTF.Ostersonntag Then mbol = 1: FeiertagsName = "Ostersonntag"  
 
'// Ostermontag berechnen (beweglicher Feiertag; 1 Tag nach Ostern)  
    m_uDTF.Ostermontag = m_uDTF.Ostern + 1
    If mdatum = m_uDTF.Ostermontag Then mbol = 1: FeiertagsName = "Ostermontag"  
 
'// Maifeiertag setzen (fester Feiertag am 1. Mai)  
    m_uDTF.Maifeiertag = DateSerial(Jahreszahl, 5, 1)
    If mdatum = m_uDTF.Maifeiertag Then mbol = 1: FeiertagsName = "Staatsfeiertag"  
 
'// Christi Himmelfahrt berechnen (beweglicher Feiertag; 39 Tage nach Ostern)  
    m_uDTF.ChrHimmelfahrt = m_uDTF.Ostern + 39
    If mdatum = m_uDTF.ChrHimmelfahrt Then mbol = 1: FeiertagsName = "Chr. Himmelfahrt"  
 
'// Pfingstsonntag berechnen (beweglicher Feiertag; 49 Tage nach Ostern)  
    m_uDTF.Pfingstsonntag = m_uDTF.Ostern + 49
    If mdatum = m_uDTF.Pfingstsonntag Then mbol = 1: FeiertagsName = "Pfingstsonntag"  
 
'// Pfingstmontag berechnen (beweglicher Feiertag; 50 Tage nach Ostern)  
    m_uDTF.Pfingstmontag = m_uDTF.Ostern + 50
    If mdatum = m_uDTF.Pfingstmontag Then mbol = 1: FeiertagsName = "Pfingstmontag"  
 
'// Fronleichnam berechnen (beweglicher Feiertag; 60 Tage nach Ostern)  
    m_uDTF.Fronleichnam = m_uDTF.Ostern + 60
    If mdatum = m_uDTF.Fronleichnam Then mbol = 1: FeiertagsName = "Fronleichnam"  
 
'// Mariä Himmelfahrt setzen (fester Feiertag am 15. August)  
    m_uDTF.MariaeHimmelfahrt = DateSerial(Jahreszahl, 8, 15)
    If mdatum = m_uDTF.MariaeHimmelfahrt Then mbol = 1: FeiertagsName = "Maria Himmelfahrt"  
 
'// Nationalfeiertag setzen (fester Feiertag am 26. Oktober)  
    m_uDTF.Nation = DateSerial(Jahreszahl, 10, 26)
    If mdatum = m_uDTF.Nation Then mbol = 1: FeiertagsName = "Nationalfeiertag"  
 
'// Reformationstag setzen (fester Feiertag am 31. Oktober)  
'// m_uDTF.Reformationstag = DateSerial(Jahreszahl, 10, 31)  
'// If mdatum = m_uDTF.Reformationstag Then mbol = True: FeiertagsTName = "Reformationstag"  
 
'// Allerheiligen setzen (fester Feiertag am 1. November)  
    m_uDTF.Allerheiligen = DateSerial(Jahreszahl, 11, 1)
    If mdatum = m_uDTF.Allerheiligen Then mbol = 1: FeiertagsName = "Allerheiligen"  
 
'// Heiligabend setzen (fester 'Feiertag' am 24. Dezember)  
'// m_uDTF.Heiligabend = DateSerial(Jahreszahl, 12, 24)  
'// If mdatum = m_uDTF.Heiligabend Then mbol = 1: FeiertagsName = "Heiligabend"  
 
'// Erster Weihnachtstag setzen (fester 'Feiertag' am 25. Dezember)  
    m_uDTF.Weihnachten1 = DateSerial(Jahreszahl, 12, 25)
    If mdatum = m_uDTF.Weihnachten1 Then mbol = 1: FeiertagsName = "Christtag"  
 
'// Zweiter Weihnachtstag setzen (fester 'Feiertag' am 26. Dezember)  
    m_uDTF.Weihnachten2 = DateSerial(Jahreszahl, 12, 26)
    If mdatum = m_uDTF.Weihnachten2 Then mbol = 1: FeiertagsName = "Stefanitag"  
 
'// Sylvester setzen (fester 'Feiertag' am 31. Dezember)  
'// m_uDTF.Sylvester = DateSerial(Jahreszahl, 12, 31)  
'// If mdatum = m_uDTF.Sylvester Then mbol = True: FeiertagsName = "Silvester"  
 
   Feiertag = mbol
 
End Function
 
Function Ostern_berechnen(ByVal lYear As Long) As Boolean
 
'// Berechnung mit Hilfe des Algorithmus von Gauß  
    On Error GoTo Err_Ostern_berechnen
 
    Dim i1  As Integer
    Dim i2  As Integer
    Dim i3  As Integer
    Dim i4  As Integer
    Dim i5  As Integer
    Dim iTZ As Integer                            '// iTZ = Tageszahl  
 
    i1 = lYear Mod 19                             '// Formel nach Gauß  
    i2 = lYear Mod 4                              '// Werte für die Jahre  
    i3 = lYear Mod 7                              '// 1900 - 2099  
 
    i4 = (19 * i1 + 24) Mod 30
    i5 = (2 * i2 + 4 * i3 + 6 * i4 + 5) Mod 7
    iTZ = 22 + i4 + i5                            '// Ermittelt den Tag  
    If iTZ > 31 Then                              '// März oder April  
        iTZ = iTZ - 31                            '// Wenn April, dann - 31 Tage  
        If iTZ = 26 Then iTZ = 19                 '// Wenn 26.4. dann 19.4.  
        If (iTZ = 25 And i4 = 28 And i1 > 10) Then iTZ = 18
        m_uDTF.Ostern = DateSerial(lYear, 4, iTZ) '// Ostern im April  
    Else
        m_uDTF.Ostern = DateSerial(lYear, 3, iTZ) '// Ostern im Maerz  
    End If
    Ostern_berechnen = True
 
Exit_Ostern_berechnen:
    Exit Function
 
Err_Ostern_berechnen:
    Ostern_berechnen = False
    GoTo Exit_Ostern_berechnen
 
End Function


Function Werktagbestimmung(Wahl As Integer, Monat As Integer) As Variant
'Parameter Wahl ' 1 = erster Arbeitstag; 2 = fünfter Arbeitstag; 3 = erster Werktag; 4 = fünfter Werktag  
'Parameter Monat ' Übergabe der aktuellen Monatszahl  
'Um ersten AT im Monat aufzurufen: Werktagbestimmung(1,Monat(Heute))  

Dim wd As Integer
Dim DatumBestimmt As Date
Dim Tageszaehler As Integer
Dim Schleifenzaehler As Integer
Dim DateFound As Boolean
Dim DateCount As Integer

Dim x As Integer
Dim y As Integer

DateFound = False
DateCount = 0

If Wahl < 3 Then 'Ersten Arbeitstag im Monat ermitteln (Mo bis Fr)  
DateFound = False
Do While DateFound = False
DateCount = DateCount + 1
If Feiertag(DateSerial(Year(Now()), Monat, DateCount), "") = False Then  
    wd = Weekday(DateSerial(Year(Now()), Monat, DateCount), vbMonday)
    If wd < 6 Then
        DatumBestimmt = DateSerial(Year(Now()), Monat, DateCount)
        DateFound = True
    End If
End If
Loop
If Wahl = 2 Then 'Fünften Arbeitstag im Monat ermitteln (Mo bis Fr)  
    DateCount = 0
    Tageszaehler = 1
    Do While Tageszaehler <> 6
        DateCount = DateCount + 1
        'If Feiertag(DatumBestimmt + DateCount, "") = False Then  
        If Feiertag(DateSerial(Year(DatumBestimmt), Month(DatumBestimmt), DateCount), "") = False Then  
            If Weekday(DateSerial(Year(DatumBestimmt), Month(DatumBestimmt), DateCount), vbMonday) < 6 Then Tageszaehler = Tageszaehler + 1
        End If
    Loop
    DatumBestimmt = DateSerial(Year(DatumBestimmt), Month(DatumBestimmt), DateCount)
End If 'Ende Ermittlung des fünften Arbeitstages (Mo bis Fr)  
End If 'Ende Ermittlung des ersten Arbeitstages (Mo bis Fr)  


If Wahl > 2 Then 'Ersten Werktag im Monat ermitteln (Mo bis Sa)  
DateFound = False
DateCount = 0
Do While DateFound = False
DateCount = DateCount + 1
If Feiertag(DateSerial(Year(Now()), Monat, DateCount), "") = False Then  
    wd = Weekday(DateSerial(Year(Now()), Monat, DateCount), vbMonday)
    If wd < 7 Then
        DatumBestimmt = DateSerial(Year(Now()), Monat, DateCount)
        DateFound = True
    End If
End If
Loop
If Wahl = 4 Then 'Fünften Werktag im Monat ermitteln (Mo bis Sa)  
    DateCount = 0
    Tageszaehler = 1
    Do While Tageszaehler <> 6
        DateCount = DateCount + 1
        If Feiertag(DateSerial(Year(DatumBestimmt), Month(DatumBestimmt), DateCount), "") = False Then  
            If Weekday(DateSerial(Year(DatumBestimmt), Month(DatumBestimmt), DateCount), vbMonday) < 7 Then Tageszaehler = Tageszaehler + 1
            wd = Weekday(DateSerial(Year(DatumBestimmt), Month(DatumBestimmt), DateCount), vbMonday)
            x = y
        End If
    Loop
    DatumBestimmt = DateSerial(Year(DatumBestimmt), Month(DatumBestimmt), DateCount)
End If 'Ende Ermittlung des fünften Werktages (Mo bis Sa)  
End If 'Ende Ermittlung des ersten Werktages (Mo bis Sa)  


Werktagbestimmung = DatumBestimmt

End Function

Sub Test()
Dim Anzeige1 As Variant
Dim Anzeige2 As Variant
Anzeige1 = Werktagbestimmung(3, 12)
Anzeige2 = Werktagbestimmung(4, 12)
MsgBox "Der Wert lautet: " & Anzeige1 & " ##  " & Anzeige2, vbOKOnly, "Titel"  

End Sub