Nur Werk- bzw. Arbeitstage

Für einen definierten Zeitraum: Nur Werk- bzw. Arbeitstage

Per Makro/VBA sollen für einen definierten Zeitraum alle Werk- oder Arbeitstage eingetragen werden. Unsere Definition: „Werktage“ ist immer Montag bis Freitag, also auch der Karfreitag oder Pfingstmontag. Und natürlich auch die Weihnachtstage, sofern sie nicht am Wochenende sind. „Arbeitstage“ sind grundsätzlich alle Werktage aber ohne die Feiertage. 

Mittels der beiden folgenden Prozeduren wird im aktuellen Arbeitsblatt entweder senkrecht (Standard) oder waagerecht der entsprechende Datumsbereich ausgefüllt. Die Start-Zelle sowie  das Format des Datums können im Code leicht angepasst werden.

Option Explicit
Option Base 1

Private Sub NurArbeitstage() 'Mo-Fr, Feiertage werden nicht geschrieben
   Dim Start As Date, Ende As Date, Hor As Boolean
   Dim Datum As Date, aDatum() As Long, AnzTage As Integer, z As Integer
   Dim rngDatum As Range
   
   Start = CDate("1.1.2016")     'Alternativ auch Zelle angeben
   Ende = CDate("31.1.2016")     '… und sonst natürlich anpassen
   'Hor = True 'Nur falls die Daten waagerecht eingetragen werden sollen
   ReDim aDatumAll(Ende - Start + 1)
   
   'Anzahl der Arbeitstage für Array festlegen
   For Datum = Start To Ende
      If Weekday(Datum, vbMonday) < 6 Then
         If Not Feiertag(Datum) Then
            AnzTage = AnzTage + 1
         End If
      End If
   Next Datum
   'Array dimensionieren und Daten hinein schreiben
   ReDim aDatum(AnzTage)
   For Datum = Start To Ende
      If Weekday(Datum, vbMonday) < 6 Then
         If Not Feiertag(Datum) Then
            z = z + 1
            aDatum(z) = CLng(Datum)
         End If
      End If
   Next Datum
   
   'Start soll B1 (horizontal) bzw. A2 sein …
   If Hor Then
      Set rngDatum = Range("B1").Resize(, AnzTage)
      rngDatum = aDatum
   Else
      Set rngDatum = Range("A2").Resize(AnzTage)
      rngDatum = WorksheetFunction.Transpose(aDatum)
   End If
   rngDatum.NumberFormat = "DD/MM/YYYY"
End Sub

Private Sub NurWerktage() 'Mo-Fr, Feiertage sind Mo-Fr Arbeitstage
   Dim Start As Date, Ende As Date, Hor As Boolean
   Dim Datum As Date, aDatum() As Long, AnzTage As Integer, z As Integer
   Dim rngDatum As Range
   
   Start = CDate("1.1.2016")     'Alternativ auch Zelle angeben
   Ende = CDate("31.1.2016")     '… und sonst natürlich anpassen
   'Hor = True 'Nur falls die Daten waagerecht eingetragen werden sollen
   ReDim aDatum(Ende - Start + 1)
   
   'Anzahl der Arbeitstage für Array festlegen
   For Datum = Start To Ende
      If Weekday(Datum, vbMonday) < 6 Then AnzTage = AnzTage + 1
   Next Datum
   'Array dimensionieren und Daten hinein schreiben
   ReDim aDatum(AnzTage)
   For Datum = Start To Ende
      If Weekday(Datum, vbMonday) < 6 Then
         z = z + 1
         aDatum(z) = CLng(Datum)
      End If
   Next Datum
   
   'Start soll B1 (horizontal) bzw. A2 sein …
   If Hor Then
      Set rngDatum = Range("B1").Resize(, AnzTage)
      rngDatum = aDatum
   Else
      Set rngDatum = Range("A2").Resize(AnzTage)
      rngDatum = WorksheetFunction.Transpose(aDatum)
   End If
   rngDatum.NumberFormat = "DD/MM/YYYY"
End Sub

Function Feiertag(Datum) As Boolean 'GMG-CC.de
   Dim Jahr As Integer, Ostern As Date, Hl3Koenige As Date
   Dim Neujahr As Date, Karfreitag As Date, OsterMontag As Date
   Dim TagDerArbeit As Date, Pfingsten As Date, PfingstMontag As Date
   Dim Himmelfahrt As Date, TagDerEinheit As Date, HeiligAbend As Date
   Dim Weihnacht1 As Date, Weihnacht2 As Date, Silvester As Date
   Dim Altweiber As Date, Rosenmontag As Date, Fronleichnam As Date
   Dim MariaHimmelfahrt As Date, Reformationstag As Date, Allerheiligen As Date
   'Bei Bedarf weitere Feiertage hier deklarieren
   
   Jahr = Year(Datum)
   'Bundes-einheitlich
   Ostern = OsterSonntag(Jahr)
   Neujahr = DateSerial(Jahr, 1, 1)
   Karfreitag = Ostern - 2
   OsterMontag = Ostern + 1
   TagDerArbeit = DateSerial(Jahr, 5, 1)
   Himmelfahrt = Ostern + 39
   Pfingsten = Ostern + 49
   PfingstMontag = Ostern + 50
   TagDerEinheit = DateSerial(Jahr, 10, 3)
   Weihnacht1 = DateSerial(Jahr, 12, 25)
   Weihnacht2 = DateSerial(Jahr, 12, 26)
   
   'Definitions-Frage
   HeiligAbend = DateSerial(Jahr, 12, 24)
   Silvester = DateSerial(Jahr, 12, 31)
   
   'Regional bedingt
   Hl3Koenige = DateSerial(Jahr, 1, 6)
   Altweiber = Ostern - 52
   Rosenmontag = Ostern - 48
   Fronleichnam = Ostern + 60
   MariaHimmelfahrt = DateSerial(Jahr, 8, 15)
   Reformationstag = DateSerial(Jahr, 10, 31)
   Allerheiligen = DateSerial(Jahr, 11, 1)
   'Bei Bedarf weitere Feiertage hier initialisieren
   
   Select Case Datum
   Case Ostern, Neujahr, Karfreitag, OsterMontag, TagDerArbeit, _
      Himmelfahrt, Pfingsten, PfingstMontag, TagDerEinheit, _
      Weihnacht1, Weihnacht2
         Feiertag = True
   ' Falls auch Feiertage, Kommentar-Marker in nächsen 2 Zeilen entfernen
'   Case HeiligAbend, Silvester
'      Feiertag = True
   ' Bei Bedarf noch weitere Feiertage nach diesem Muster hinzufügen
   End Select   
End Function

Function OsterSonntag(Jahr As Integer)
   Dim d As Integer
    d = (((255 - 11 * (Jahr Mod 19)) - 21) Mod 30) + 21
    OsterSonntag = DateSerial(Jahr, 3, 1) + d + (d > 48) + 6 - ((Jahr + Jahr \ 4 + d + (d > 48) + 1) Mod 7)
End Function

▲ nach oben …

Dieser Beitrag wurde unter Code-Schnipsel, Datum und Zeit, Mit VBA/Makro, Verschiedenes abgelegt und mit , , , , , verschlagwortet. Setze ein Lesezeichen auf den Permalink.