letzter/erster Arbeitstag im Quartal unter Berücksichtigung von Hasen und Popen

[d'r Bastler]

Moin allerseits,

ursprüngliche Aufgabe war, den letzten Arbeitstag eines Quartals zu errechnen. Ich habe ein bisschen weitergebastelt und der Code unten kann jetzt Folgendes: Es wird
1. nicht nur das Datum, sondern auch der Wochentag des Quartalsletzten errechnet
2. auch der nächste Quartalserste darf entsprechend mitspielen
3. werden natürlich die unvermeidlichen Hasen- und Popenparties berücksichtigt. Wobei letztere den einzig beteiligten gesetzlichen Feiertag Neujahr meint.

Code: Alles auswählen

Option Explicit

Sub WorkdaysQuartsEnd()
Dim i As Integer, sCase As String, wsf As WorksheetFunction, aDays
Dim dKey As Date, dLast As Date, dNext As Date, dEgg As Date
Dim iKey As Integer, iLast As Integer, iNext As Integer, iEgg As Integer
Dim sKey As String, sLast As String, sNext As String, sEgg As String

Set wsf = WorksheetFunction
aDays = Array("Mo", "Di", "Mi", "Do", "Fr", "Sa", "So")
dEgg = HasenParty(Year(Date))

For i = 3 To 12 Step 3
'Quartalsletzer
    sKey = "01." & i & "." & Year(Date)
    dKey = DateSerial(Year(sKey), Month(sKey) + 1, 1) - 1
    iKey = wsf.Weekday(dKey, 2)
    sKey = aDays(iKey - 1)
    
'Hasenfall
    Select Case dKey
        Case dEgg - 2, dEgg - 1, dEgg, dEgg + 1
                Select Case True
                    Case dKey = dEgg + 1
                        dLast = dKey - 4: iLast = wsf.Weekday(dLast, 2): sLast = aDays(iLast - 1)
                        iKey = wsf.Weekday(dKey, 2): sKey = aDays(iKey - 1)
                        dNext = dEgg + 1: iNext = wsf.Weekday(dNext, 2): sNext = aDays(iNext - 1)
                    Case dKey = dEgg
                        dLast = dKey - 3: iLast = wsf.Weekday(dLast, 2): sLast = aDays(iLast - 1)
                        iKey = wsf.Weekday(dKey, 2): sKey = aDays(iKey - 1)
                        dNext = dEgg + 2: iNext = wsf.Weekday(dNext, 2): sNext = aDays(iNext - 1)
                    Case dKey = dEgg - 1
                        dLast = dKey - 2: iLast = wsf.Weekday(dLast, 2): sLast = aDays(iLast - 1)
                        iKey = wsf.Weekday(dKey, 2): sKey = aDays(iKey - 1)
                        dNext = dEgg + 3: iNext = wsf.Weekday(dNext, 2): sNext = aDays(iNext - 1)
                    Case dKey = dEgg - 2
                        dLast = dKey - 1: iLast = wsf.Weekday(dLast, 2): sLast = aDays(iLast - 1)
                        iKey = wsf.Weekday(dKey, 2): sKey = aDays(iKey - 1)
                        dNext = dEgg + 4: iNext = wsf.Weekday(dNext, 2): sNext = aDays(iNext - 1)
                End Select
        sCase = ">>> HasenParty <<<"
        MsgBox "Letzter: " & vbTab & vbTab & sLast & vbTab & dLast & vbNewLine & _
            "Stichtag: " & vbTab & sKey & vbTab & dKey & vbNewLine & _
            "Nächster: " & vbTab & sNext & vbTab & dNext, , sCase
    i = i + 3
    End Select
    
'Normalfall -> Zurücksetzen der Variablen aus'm Hasenfall
    sKey = "01." & i & "." & Year(Date)
    dKey = DateSerial(Year(sKey), Month(sKey) + 1, 1) - 1
    iKey = wsf.Weekday(dKey, 2)
    sKey = aDays(iKey - 1)
    
    Select Case sKey
        Case "Sa"
            dLast = dKey - 1: iLast = wsf.Weekday(dLast, 2): sLast = aDays(iLast - 1)
            iKey = wsf.Weekday(dKey, 2): sKey = aDays(iKey - 1)
            dNext = dKey + 2: iNext = wsf.Weekday(dNext, 2): sNext = aDays(iNext - 1)
        Case "So"
            dLast = dKey - 2: iLast = wsf.Weekday(dLast, 2): sLast = aDays(iLast - 1)
            iKey = wsf.Weekday(dKey, 2): sKey = aDays(iKey - 1)
            dNext = dKey + 1: iNext = wsf.Weekday(dNext, 2): sNext = aDays(iNext - 1)
        Case Else
            dLast = dKey: iLast = wsf.Weekday(dLast, 2): sLast = aDays(iLast - 1)
            iKey = wsf.Weekday(dKey, 2): sKey = aDays(iKey - 1)
            dNext = dKey + 1: iNext = wsf.Weekday(dNext, 2): sNext = aDays(iNext - 1)
    End Select
    sCase = ">>> Normalfall <<<"
'Popenfall
    If dNext > "31.12." & Year(Date) Then
        dNext = dNext + 1: sNext = aDays(iNext)
        sCase = ">>> PopenParty <<<"
    End If
        MsgBox "Letzter: " & vbTab & vbTab & sLast & vbTab & dLast & vbNewLine & _
            "Stichtag: " & vbTab & sKey & vbTab & dKey & vbNewLine & _
            "Nächster: " & vbTab & sNext & vbTab & dNext, , sCase
Next i

End Sub

Public Function HasenParty(iYear As Integer) As Date
Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer
Dim iDay As Integer, iMonth As Integer

a = iYear Mod 19: b = iYear Mod 4: c = iYear Mod 7
d = (19 * a + 24) Mod 30: e = (2 * b + 4 * c + 6 * d + 5) Mod 7

iDay = 22 + d + e: iMonth = 3
    If iDay > 31 Then
        iDay = d + e - 9
        iMonth = 4
    End If
    
    If iDay = 26 And iMonth = 4 Then iDay = 19
    If iDay = 25 And iMonth = 4 And d = 28 And e = 6 And a > 10 Then iDay = 18

HasenParty = DateSerial(Year:=iYear, Month:=iMonth, Day:=iDay)

End Function

Sinnvollerweise sollte der Code in ein Allg. Modul und dann die Ein/Ausgaben entsprechend angepasst werden.

Viel Spaß damit!

lg

[RPP63]

Moin!
Mal ein etwas gestraffter Code.
Ich benötige 3 UDFs, die als Argument die Übergabe einer Jahreszahl y benötigen:

Code: Alles auswählen

Function Erster_AT_Quartal(y&)
Dim arr#(3), i&
For i = 1 To 4  'Quartale
  arr(i - 1) = WorksheetFunction.WorkDay(DateSerial(y, i * 3 + 1, 0), 1, FT(y))
Next
Erster_AT_Quartal = Application.Transpose(arr)
End Function

Code: Alles auswählen

Function Letzter_AT_Quartal(y&)
Dim arr#(3), i&
For i = 1 To 4  'Quartale
  arr(i - 1) = WorksheetFunction.WorkDay(DateSerial(y, i * 3 + 1, 1), -1, FT(y))
Next
Letzter_AT_Quartal = Application.Transpose(arr)
End Function

Code: Alles auswählen

Function FT(y&)
Dim arr#(2), OS#
OS = Round(DateSerial(y, 4, Day(Minute(y / 38) / 2 + 55)) / 7, 0) * 7 - 6
arr(0) = DateSerial(y, 1, 1)  'Neujahr
arr(1) = OS - 2               'Karfreitag
arr(2) = OS + 1               'Ostermontag
FT = arr
End Function

Ich rufe dann in einem leeren(!) Tabellenblatt folgendes Makro auf:

Code: Alles auswählen

Sub Test()
Const y& = 2024
Cells.Delete
Range("A1") = "Erster_AT_Quartal"
With Range("A2:A5")
  .NumberFormat = "ddd dd.mm."
  .Value = Erster_AT_Quartal(y)
End With
Range("B1") = "Letzter_AT_Quartal"
With Range("B2:B5")
  .NumberFormat = "ddd dd.mm."
  .Value = Letzter_AT_Quartal(y)
End With
ActiveSheet.Columns.AutoFit
End Sub

Ergibt:
Erster_AT_Quartal Letzter_AT_Quartal
Di 02.04. Do 28.03.
Mo 01.07. Fr 28.06.
Di 01.10. Mo 30.09.
Mi 01.01. Di 31.12.

Gruß Ralf

[d'r Bastler]

Moin Ralf,

da sucht man sich als VBAstler 'nen Wolf nach einer modernen Hasenparty-Formel, strandet dann bei einer uralt-Version nach Gauss und Du packst das Dingen einfach in 'nen Einzeiler!!

OS = Round(DateSerial(y, 4, Day(Minute(y / 38) / 2 + 55)) / 7, 0) * 7 - 6

Beeindruckend!! Vielen Dank!

Schönes Wochenende

[RPP63]

Da war ein Fehler in Erster_AT_Quartal!
Richtig ist:

Code: Alles auswählen

Function Erster_AT_Quartal(y&)
Dim arr#(3), i&
For i = 1 To 4  'Quartale
  arr(i - 1) = WorksheetFunction.WorkDay(DateSerial(y, i * 3 - 2, 0), 1, FT(y))
Next
Erster_AT_Quartal = Application.Transpose(arr)
End Function

[xlKing]

da sucht man sich als VBAstler 'nen Wolf nach einer modernen Hasenparty-Formel, strandet dann bei einer uralt-Version nach Gauss und Du packst das Dingen einfach in 'nen Einzeiler!!

Wow wie viele dieser Einzeiler gibt's denn noch? Das ist nun schon die achte Version, die ich sehe. Aber wie alle anderen Einzeiler ist auch dieser leider falsch. Zumindest kommt hier zwar immer Sonntag raus. Das ist schon mal ein Fortschritt. Aber dieser ist leider manchmal um ein bis zwei Wochen verschoben. Ein Beispiel: 2011 war der Ostersonntag am 24. April. Die Formel kommt aber auf den 17. April. Der Fehler wiederholt sich alle paar Jahre. Je höher das Jahr wird, desto falscher das Ergebnis. Richtig ist nur Gauss z.B. nach der auf Wikipedia veröffentlichten Version.

Zu diesem Thema hatte ich letztes Jahr mal einen Thread drüben im VBA-Forum. So richtig konnte mir dort aber auch keiner beantworten, wo die vielen falschen Einzeiler herkommen.

Gruß Mr. K.

[RPP63]

Die Formel respektive UDF ermittelt für 2011 korrekt den 24.04.
Ich habe mal flugs mit der absolut korrekten Lichtenberg-Erweiterung der Gauß-Formel gegengecheckt.
Einziger Fehler (von 1990 bis 2189) ist in 2079.
Meine UDF gemäß Lichtenberg ist

Code: Alles auswählen

Public Function Ostersonntag(ByVal j As Integer) As Date
Dim x(9) As Long
   x(0) = j \ 100
   x(1) = 15 + (3 * x(0) + 3) \ 4 - (8 * x(0) + 13) \ 25
   x(2) = 2 - (3 * x(0) + 3) \ 4
   x(3) = j Mod 19
   x(4) = (19 * x(3) + x(1)) Mod 30
   x(5) = (x(4) + x(3) \ 11) \ 29
   x(6) = 21 + x(4) - x(5)
   x(7) = 7 - (j + j \ 4 + x(2)) Mod 7
   x(8) = 7 - (x(6) - x(7)) Mod 7
   x(9) = x(6) + x(8)
Ostersonntag = DateSerial(j, 3, x(9))
'denn der 32.3. ist automatisch der 1.4.
End Function

[Gast]

Moment!
Die Excelformel
=RUNDEN((TAG(MINUTE(2011/38)/2+55)&".4."&2011)/7;0)*7-6
ergibt korrekt den 24.4.
hingegen liefert der transformierte VBA-Einzeiler
CDate(Round(DateSerial(2011, 4, Day(Minute(2011 / 38) / 2 + 55)) / 7, 0) * 7 - 6)
falsch den 17.4.

[xlKing]

Ja, irgendwas muss 2079 sein. Da kommen nämlich fast alle Einzeiler auf den 16.04.

Aber auch die Excelformel ergibt ein anderes Ergebnis als Gauss. Ab 2204 gehts dann auch hier los mit Unterschieden zu Gauss alle paar Jahre. Ab 3700 ist dann in jedem Jahr eine Abweichung. Im Jahr 3721 beträgt die Abweichung ganze 3 Wochen! Meine Frage bleibt nach wie vor bestehen: Wonach richten sich Kirche und Kalender-Hersteller? Vielleicht hat sich ja auch Gauss geirrt und der Mond kommt ganz anders als von ihm berechnet. Nur interessiert das überhaupt jemanden beim Kalenderdruck?

Gruß Mr. K.

[RPP63]

Die (weit) entfernte Zukunft dürfte bei allen Einzeilern Rundungsfehler produzieren, die beim Lichtenberg'schen Gleichungssystem mit 10(!) Variablen nicht auftreten.
Aber mal im Ernst:
Wen interessiert der Ostersonntag in 100 Jahren?
Man darf sich ja nicht mal sicher sein, dass der Kalender in 20 Jahren überhaupt noch christlichen Bezug hat …

[thowe]

Hallöchen!

Ihr rechnet mit Datumsformat 1900?

Folgende Formel rechnet im Datumsformat 1900 und 1904 korrekt (angeblich...?)

Code: Alles auswählen

=DM((4&-A2)/7-TAG(8)/7+REST(44*REST(A2;19)-10-4*DM(68%*DM(A2%-3,5;)-KURZEN(A2%/4););4,13796);)*7+TAG(1) 

Quelle: https://www.konschak.de/formel-ostersonntag/ -> die wir euch - eh - bekannt sein..

lg