Nettoarbeitstage in VBA
24.11.2014 14:18:06
Werner
ich habe schon seit langem folgenden Code (Quelle unbekannt)
der mir zwischen 2 Datumsangaben die Nettoarbeitstage berechnet.
Der funktioniert auch wunderbar - nur leider macht er einen kleinen Fehler
Ist das Start-Datum = End-Datum, berechnet er mir immer den Wert 0
(und nicht 1, wenn der Tag ein normaler Arbeitstag ist)
Wir nutzen diese Formeln, da unser Admin das entspr Analyse-AddIn gesperrt hat.
Hat jemand einen Tip, diesen "Mini-Fehler" zu korrigieren ?
Besten Gruss
Werner
hier der Code:
Option Explicit
Public Function ArbTag(Datum As Range, Optional ArbeitsTage As Range, Optional FreieTage As _
Range)
'Auflistung Arbeitstage mit Berücksichtigung der Feiertage + optional zusätzliche ArbeitsTage
'und / oder zusätzliche freie Tage!
Dim i%
Application.Volatile
If IsDate(Datum) Then
If ArbeitsTage Is Nothing And FreieTage Is Nothing Then
For i = 1 To 5
If ATag(Datum + i) = 1 Then
Exit For
End If
Next
ElseIf ArbeitsTage Is Nothing Then
For i = 1 To 1000
If ATag(Datum + i) = 1 And Application.IsNumber(Application.Match(CLng(Datum + i), _
FreieTage, 0)) = False Then
Exit For
End If
Next
ElseIf FreieTage Is Nothing Then
For i = 1 To 1000
If ATag(Datum + i) Or Application.IsNumber(Application.Match(CLng(Datum + i), ArbeitsTage, _
0)) Then
Exit For
End If
Next
Else
For i = 1 To 1000
If ATag(Datum + i) And Application.IsNumber(Application.Match(CLng(Datum + i), FreieTage, _
0)) = False _
Or Application.IsNumber(Application.Match(CLng(Datum + i), ArbeitsTage, 0)) Then
Exit For
End If
Next
End If
End If
ArbTag = Datum + i
End Function
Public Function NettoArbTage(Beginn As Date, Ende As Date, Optional ArbeitsTage As Range, _
Optional FreieTage As Range)
'Berechnung NettoArbeitstage mit Berücksichtigung der Feiertage + optional zusätzliche _
ArbeitsTage
'und / oder zusätzliche freie Tage!
Application.Volatile
If IsDate(Beginn) And IsDate(Ende) And Beginn Public Function ATag(Datum As Date) As Integer
'!!! Achtung : Feiertage, bitte anpassen !!!
Dim Feiertage(13) As Date
Dim Jahr%, WTag%, i&
Jahr = CInt(Format(Datum, "yyyy"))
WTag = CInt(Weekday(Datum, 2))
ATag = 1
If WTag > 5 Then
ATag = 0
Else
' Feiertage
' Karfreitag
Feiertage(0) = (Ostersonntag(Jahr)) - 2
' Ostermontag
Feiertage(1) = (Ostersonntag(Jahr)) + 1
' Christi Himmelfahrt
Feiertage(2) = (Ostersonntag(Jahr)) + 39
' Pfingstmontag
Feiertage(3) = (Ostersonntag(Jahr)) + 50
' Fronleichnam
Feiertage(4) = (Ostersonntag(Jahr)) + 60
' Neujahr
Feiertage(5) = CDate("01.01." & Jahr)
' 1.Mai
Feiertage(6) = CDate("01.05." & Jahr)
' Maria Himmelfahrt > kein Feiertag
'Feiertage(7) = CDate("15.08." & Jahr)
' Tag der deutschen Einheit
If Jahr kein Feiertag
'Feiertage(9) = CDate("01.11." & Jahr)
' Weihnachtstag
Feiertage(10) = CDate("24.12." & Jahr)
' 1. Weihnachtstag
Feiertage(11) = CDate("25.12." & Jahr)
' 2.Weihnachtstag
Feiertage(12) = CDate("26.12." & Jahr)
' Sylvester
Feiertage(13) = CDate("31.12." & Jahr)
' Ist das Datum ein Feiertag?
For i = 0 To 13
If Datum = Feiertage(i) Then
ATag = 0
Exit For
End If
Next i
End If
End Function
Dim intA As Integer, intB As Integer, intC As Integer, intD As Integer
Dim intE As Integer, intF As Integer, intG As Integer, intH As Integer
Dim intI As Integer, intK As Integer, intL As Integer, intM As Integer
Dim intN As Integer, intP As Integer
Application.Volatile
Select Case Jahr
Case Is >= 1900
intA = Jahr Mod 19
intB = Int(Jahr / 100)
intC = Jahr Mod 100
intD = Int(intB / 4)
intE = intB Mod 4
intF = Int((intB + 8) / 25)
intG = Int((intB - intF + 1) / 3)
intH = (19 * intA + intB - intD - intG + 15) Mod 30
intI = Int(intC / 4)
intK = intC Mod 4
intL = (32 + 2 * intE + 2 * intI - intH - intK) Mod 7
intM = Int((intA + 11 * intH + 22 * intL) / 451)
intN = Int((intH + intL - 7 * intM + 114) / 31)
intP = (intH + intL - 7 * intM + 114) Mod 31
Ostersonntag = DateSerial(Jahr, intN, intP + 1)
End Select
End Function