vb@rchiv · Tipps & Tricks · Arbeitstage berechnen ohne Loop

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