VBA Code Änderung Access 2010

Liebe Gemeinde,

ein Kollege hat mir einmal einen VBA Code zur Ermittlung des 1. und 5. Arbeitstags eines Monats erstellt, nun bräcuhte ich aber den 2. und 6. Arbeitstag eines Monats, ich schaffe es aber nicht den Code dementsprechend zu ändern, bitte um Hilfe:

Der Code besteht aus einer Feiertagsberechnung mit anschließender Werktagsbestimmung(Funktion wird in als Kriterium in die Abfrage in ein Datumsfeld geschrieben), die Funktion "Werktagbestimmung" enthält den besagten Code, unterhalb):

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

Wie muss der Code aussehen damit der 2. und 6. Arbeitstag bestimmt wird(ACHTUNG, nicht der Werktag, diese Funktion ist auch im Code enthalten!)

Vielen Dank!

Gruß

Dr.

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 338215

Url: https://administrator.de/forum/vba-code-aenderung-access-2010-338215.html

Ausgedruckt am: 26.12.2024 um 12:12 Uhr

6 Kommentare

Neuester Kommentar

Moin,

auf den ersten Blick würde ich sagen, du brauchst einen zusätzliche IF-Abfrage und while loop (Zeile 200-209) in dem du abprüfst ob "Tageszaehler" <> 3 (für den 2ten) bzw. <>7 (für den 6ten) Arbeitstag.

Schonmal so versucht?

lg,
Slainte

Mojn,

hab bis jetzt nur beim Code:

DatumBestimmt = DateSerial(Year(Now()), Monat, DateCount)

+ 1 ergänzt, dann hab ich aber das Problem wenn zb. der 1. Arbeitstag ein Freitag ist(er würde dann als 2. Arbeitstag den Samstag sehen = keine Daten vorhanden).

Ehrlich gesagt blicke ich bei dem Code nicht mehr ganz durch , darum hat ihn mir auch ein Kollegen geschrieben.

Danke!

Gruß

Dr.

Ehrlich gesagt blicke ich bei dem Code nicht mehr ganz durch

Der Codeblock Zeile 200 bis 209 (und die anderen "Baugleichen" iFs mit den loops dahinter) zaehlen die Arbeits bzw. Werktage durch, und wenn die gewünschte Anzahl an Tagen erreicht ist (Zeile 203) dann wird der Loop verlassen und das so bestimmte Datum zurück gegeben..

Du kannst auch einfach mal durch die Funktion durchsteppen, dann siehst du genau was passiert.

Moin,

vielen Dank für deine Hilfe, hab mir den Kopf zerbrochen und den Code noch einmal neu geschrieben um ihn besser zu verstehen und ich denke jetzt klappt es mit dem 2. und 6. Arbeitstag.

Function Arbeitstagermittlung(Wahl As Integer, Monat As Integer) As Variant

Dim Datumzahl As Integer
Dim wd As Integer
Dim BestimmtesDatum As Date
Dim Tageszahl As Integer

Datumzahl = 0

If Wahl < 3 Then
    Tageszahl = 0
    Do While Tageszahl <> 2
        Datumzahl = Datumzahl + 1
        If Feiertag(DateSerial(Year(Now()), Monat, Datumzahl), "") = False Then  
            wd = Weekday(DateSerial(Year(Now()), Monat, Datumzahl), vbMonday)
            If wd < 6 Then
                Tageszahl = Tageszahl + 1
                BestimmtesDatum = DateSerial(Year(Now()), Monat, Datumzahl)
            End If
        End If
    Loop
    
If Wahl = 2 Then
    Datumzahl = 0
    Tageszahl = 0
    Do While Tageszahl <> 6
        Datumzahl = Datumzahl + 1
        If Feiertag(DateSerial(Year(BestimmtesDatum), Month(BestimmtesDatum), Datumzahl), "") = False Then  
            If Weekday(DateSerial(Year(BestimmtesDatum), Month(BestimmtesDatum), Datumzahl), vbMonday) < 6 Then
                Tageszahl = Tageszahl + 1
                BestimmtesDatum = DateSerial(Year(Now()), Monat, Datumzahl)
            End If
        End If
    Loop
End If
End If

Arbeitstagermittlung = BestimmtesDatum

End Function

Was ich noch immer nicht ganz verstehe ich diese Feiertags Funktion, sie zählt also die einzelnen Tage vom Monat durch, ist davon einer ein Feiertag, dann zählt er diesen nicht, aber warum ist dann beim Feiertagsnamen ein "" eingetragen und dann auch noch ein FALSE am Ende?

If Feiertag(DateSerial(Year(Now()), Monat, DateCount), "") = False Then  

DAs würde dann doch bedeuten:

Ist der zu prüfende Tag nicht(FALSE) kein("") Feiertag, dann zähle weiter, oder verstehe ich dies falsch.

Wäre toll wenn mir das noch jemand erklären könnte.

Vielen Dank!

Gruß

Dr.

Zitat von @Dr.Cornwallis:

Moin,

vielen Dank für deine Hilfe, hab mir den Kopf zerbrochen und den Code noch einmal neu geschrieben um ihn besser zu verstehen und ich denke jetzt klappt es mit dem 2. und 6. Arbeitstag.

Function Arbeitstagermittlung(Wahl As Integer, Monat As Integer) As Variant
> 
> Dim Datumzahl As Integer
> Dim wd As Integer
> Dim BestimmtesDatum As Date
> Dim Tageszahl As Integer
> 
> Datumzahl = 0
> 
> If Wahl < 3 Then
>     Tageszahl = 0
>     Do While Tageszahl <> 2
>         Datumzahl = Datumzahl + 1
>         If Feiertag(DateSerial(Year(Now()), Monat, Datumzahl), "") = False Then  
>             wd = Weekday(DateSerial(Year(Now()), Monat, Datumzahl), vbMonday)
>             If wd < 6 Then
>                 Tageszahl = Tageszahl + 1
>                 BestimmtesDatum = DateSerial(Year(Now()), Monat, Datumzahl)
>             End If
>         End If
>     Loop
>     
> If Wahl = 2 Then
>     Datumzahl = 0
>     Tageszahl = 0
>     Do While Tageszahl <> 6
>         Datumzahl = Datumzahl + 1
>         If Feiertag(DateSerial(Year(BestimmtesDatum), Month(BestimmtesDatum), Datumzahl), "") = False Then  
>             If Weekday(DateSerial(Year(BestimmtesDatum), Month(BestimmtesDatum), Datumzahl), vbMonday) < 6 Then
>                 Tageszahl = Tageszahl + 1
>                 BestimmtesDatum = DateSerial(Year(Now()), Monat, Datumzahl)
>             End If
>         End If
>     Loop
> End If
> End If
> 
> Arbeitstagermittlung = BestimmtesDatum
> 
> End Function

If Feiertag(DateSerial(Year(Now()), Monat, DateCount), "") = False Then  

Ich glaub ich hab's gerade kapiert, da die Funktion eigentlich kein Boolean ist sondern ein Integer, gibt die Feiertagsfunktion entweder ein 0 oder 1 aus, FALSE ist das selbe wie 0, darum funktioniert der Code auch mit FALSE(könnte auch if Feiertag = 0 Then heißen).

Gruß

Dr.