Rubrik: Datum/Zeit und Timer · Datums- und Zeitfunktionen | VB-Versionen: VB6 | 22.05.06 |
Arbeitstage berechnen ohne Loop Funktion zum Berechnen eines Datums auf Basis von anzugebenen Arbeitstage (ohne zeitaufwendigen Loop) | ||
Autor: Holger Möller | Bewertung: | Views: 20.136 |
ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Die folgende Funktion berechnet unter Angabe eines Startdatums (dt) und einer Anzahl von Arbeitstagen einen Arbeitstag in der Zukunft (n>0) oder in der Vergangenheit (n<0). Bei Auswahl von 0 wird der nächste folgende Arbeitstag ermittelt, wenn das Startdatum (dt) ein Sonnabend oder Sonntag ist.
Vorteil der Funktion: Es wird auf einen zeitaufwendigen Loop verzichtet, so dass sich auch große Zeitabstände schnell berechnen lassen.
Public Function GetWorkDate(ByVal dt As Date, ByVal n As Long) As Date Dim Wd As Integer Dim Wk As Double Dim Wk2 As Long Dim Rd As Long ' dt = Startdatum ' n = Anzahl Arbeitstage ' Wd = Wochentag ' Wk = Anzahl Arbeitswochen ' Wk2 = Abgerundete Anzahl Geschäftswochen ' Rd = Resttage zum ermittelten Datum zu ergänzen ' Ermittle Wochentag vom Startdatum Wd = Weekday(dt, vbMonday) If Wd = 6 Then ' Ist Startdatum = Sa dann gehe zurück zu Freitag (n > 1) oder Montag (n < 1) If n < 1 Then dt = dt + 2 Else dt = dt - 1 ElseIf Wd = 7 Then ' Ist Startdatum = Sa dann gehe zurück zu Freitag (n > 1) oder Montag (n < 1) If n < 1 Then dt = dt + 1 Else dt = dt - 2 End If ' Ermittle Anzahl Arbeitswochen (mit Kommastelle) / Arbeitswoche hat 5 Tage Wk = Round(n / 5, 1) ' Ermittle Ganzzahl der Arbeitswochen Wk2 = Int(Wk) ' Errechne neues Datum berechnet mit Kalenderwochen auf Basis Arbeitswochen (7 Tage Woche) dt = dt + (Wk2 * 7) ' Ermittle aus Rest der verbleibenden Woche die Anzahl Tage (Nachkommastelle von Wk) Rd = (Wk - Wk2) * 5 ' Sollte das endgültige Datum auf einen Sa oder So fallen, rechne nochmal 2 Tage hinzu If (Weekday(dt, vbMonday) + Rd) > 5 Then Rd = Rd + 2 ' Errechne den endgültigen Arbeitstag durch Hinzurechnen der Resttage GetWorkDate = dt + Rd End Function