Makro:Vor und Nachfeiertage
Aus XIMES
Inhaltsverzeichnis |
Was tut es?
Basierend aufder Standardfeiertagslise zB aus OPA, SPA im Format
Neujahrestag, 1999/01/01
werden Vorfeiertage, Nachfeiertage, Letzter Freitag vor einem Montag-Feiertag sowie die Weihnachtstage berechnet.
Betriebsurlaube etc. könnten hier auch als Listeerzeugt werden.
Was ist vorausgesetzt?
- Kalenderdaten in Excel einspielen
- Spalte ergänzen mit Wochentagesnummer (zB Wochentag ....)
- Name vergeben
- eigenes leeres Ergebnisblatt RESULT
Makro
Option Explicit
'
' Hilft Kalender mit Vor und Nachfeiertage und letzter Werktag vor Montag-Feiertag zu finden
'
Public Sub KalenderMachen() 'Für TIS
Dim Result As Range
Dim Dat As Range
Dim line As Long
Dim I As Long
Dim J As Long
Dim delta As Integer
Dim datumWert, beginn, ende As Date
Dim jahr, jahrvorher As Integer
'
Set Dat = Range("Datum")
'Eingangsbedingungen: Named Range mit nach DATUM AUFSTEIGEND SORTIERTEN WERTEN
' Spalte 1 Name des Feiertages
' Spalte 2 Datum des FEIERTAGES
' Spalte 3 Nr Wochentag mit 1 = Mo
'
' Dorthin kommen ERgebnisse
Set Result = Worksheets("Result").Cells
Result.ClearContents
Result.Name = "Result"
'
' Initialisierung
Result(1, 1) = "Art, Datum"
'
line = 2
jahrvorher = 0
'
For I = 2 To Dat.Rows.Count
'
If Dat(I, 1) <> "" Then
' ---- so erfolgt Anpassung
' if true in If FALSE umstellen, wenn das nicht gebraucht wird
' es wird in Reihenfolge
'
' Drucken Weihnachtstage - wird immer geschrieben unabhängig von Weihnachtstage - EVENTUELL Tage anpassen
If True Then
datumWert = Dat(I, 2)
jahr = Year(datumWert)
'
If jahrvorher < jahr Then
'Weihnachtszeit
For J = 22 To 31
printquick Result, line, "Weihnacht+Neujahr", DateSerial(jahr, 12, J)
Next
'
For J = 1 To 5
printquick Result, line, "Weihnacht+Neujahr", DateSerial(jahr, 1, J)
Next
jahrvorher = jahr
End If
End If
'
'Drucken Datum Feiertag direkt
If True Then
If KommtNichtAlsAndererTagvor(Result, 2, line - 1, Dat(I, 2), 100) Then
'So weit zurück gesucht wegen Weihnachten
printquick Result, line, "Feiertag", Dat(I, 2)
End If
End If
'
'Drucken Datum Vor-Feiertag (wird nicht verwendet, wenn der Tag davor schon ein Feiertag ist)
If True Then
If KommtNichtAlsAndererTagvor(Dat, 2, I, Dat(I, 2) - 1) Then
printquick Result, line, "Vor-Feiertag", Dat(I, 2) - 1
End If
End If
'
'Drucken Datum Nach-Feiertag - (wird nicht verwendet, wenn der Tag davor schon ein Feiertag ist)
If True Then
If KommtNichtAlsAndererTagvor(Dat, 2, I + 5, Dat(I, 2) + 1) Then
printquick Result, line, "Nach-Feiertag", Dat(I, 2) + 1
End If
End If
'
'Drucken Datum Mo-Fr vorFeiertag - (wird nicht verwendet, wenn der Tag schon irgendwo vorkommt)
If True Then
'Bestimmen letzter Werktag - Eingangsvoraussetzung ist Mo=1
'wirkt nur wenn Tag vorher nicht schon was anderes ist
If Dat(I, 3) = 1 Then delta = -3 Else delta = 0 'er war drei Tage vorhe
'
'rein, wenn nicht schon was anderes dort steht
If KommtNichtAlsAndererTagvor(Result, 2, line, Dat(I, 2) + delta) And delta <> 0 Then
printquick Result, line, "letzter Werktag vor Ftg.", Dat(I, 2) + delta
End If
End If
'
'
End If
Next
'
'
End Sub
Hilfsfunktionen
'Hilfsfunktion für Ausgabe
Private Sub printquick(wohin As Range, line As Long, text As String, datum As Variant, Optional bGeheNächsteZeile As Boolean = True)
'
wohin(line, 1) = text & ", " & Year(datum) & "/" & Month(datum) & "/" & Day(datum)
'
If bGeheNächsteZeile Then line = line + 1
'
End Sub
'Hilfsfunktion für Prüfung
Private Function KommtNichtAlsAndererTagvor(ByRef Suchbereich As Range, Suchspalte As Integer, abZeile As Long, Wert As Variant, Optional FürZeilen As Integer = 50) As Boolean
Dim I As Long
Dim wertSpalte As Date
'
KommtNichtAlsAndererTagvor = True
'
If FürZeilen > abZeile Then FürZeilen = abZeile - 1
'
For I = abZeile To abZeile - FürZeilen + 1 Step -1
If I > 1 Then wertSpalte = Suchbereich.Cells(I, Suchspalte)
If Wert = wertSpalte Then
KommtNichtAlsAndererTagvor = False
End If
Next
'
End Function
