AW: Feiertage überspringen
15.12.2008 17:08:00
fcs
Hallo Nils,
die Variablen muss du nicht alle umbnennen. Allerdings müsste man man eine etwas andere Strategie fahren, um den Variablen Werte zuzuweisen.
Ganz ideal ist es, die Parameter "Tage", die gefärbt werden sollen, und "Farbe für Tag" als ArrayVariable an die Prozedur zu übergeben. Da müsste man aber nochmals etwas umstricken. Wobei die Sub NextWorkday unverändert bleibt.
Gruß
Franz
'Modifizierte Prozedur
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zelle As Range, arrTage, arrFarben
Const SpalteDatum = 5 'Spalte E in der Startdatum überwacht werden soll
Const Zeile1 = 4 '1. zeile ab der Eingabedatum überwacht werden soll
'Prüfen ob Eingabezelle in Spalte "SpalteDatum" unterhalb von "Zeile1" geändert wurde
'Es können innerhalb der Spalte auch mehrere Zellen geändert werden.
If Not Intersect(Target, Range(Cells(Zeile1, SpalteDatum), Cells(Rows.Count, _
SpalteDatum))) Is Nothing Then
Application.EnableEvents = False
For Each Zelle In Target
If Zelle.Column = SpalteDatum And Cells(Zelle.Row, 36).Value "" Then
'Array mit den Tagen inkl. Starttag die eingefärbt werden sollen
'Tage bitte aufsteigend im Array angeben
arrTage = Array(1, 2, 3, 5)
'Array mit den ColorIndex-Farben zu den Tagen, _
Array muss die gleiche Anzahl einträge haben wie arrTage!
arrFarben = Array(3, 4, 6, 5)
Call Autoformat(wks:=Worksheets("Kalender"), Startvar:=Zelle.Value, _
Zeile:=Zelle.Row, zeileDatum:=3, spalteDatum1:=5, arrTage:=arrTage, _
arrFarben:=arrFarben, GrundFarbe:=2)
ElseIf Zelle.Column = SpalteDatum And Cells(Zelle.Row, 37).Value "" Then
arrTage = Array(1, 7, 10, 11, 12)
arrFarben = Array(3, 6, 5, 7, 19)
Call Autoformat(wks:=Worksheets("Kalender"), Startvar:=Zelle.Value, _
Zeile:=Zelle.Row, zeileDatum:=3, spalteDatum1:=5, arrTage:=arrTage, _
arrFarben:=arrFarben, GrundFarbe:=2)
ElseIf Zelle.Column = SpalteDatum And Cells(Zelle.Row, 38).Value "" Then
arrTage = Array(1, 7, 14, 21)
arrFarben = Array(3, 6, 5, 7)
Call Autoformat(wks:=Worksheets("Kalender"), Startvar:=Zelle.Value, _
Zeile:=Zelle.Row, zeileDatum:=3, spalteDatum1:=5, arrTage:=arrTage, _
arrFarben:=arrFarben, GrundFarbe:=22)
End If
Next
Application.EnableEvents = True
End If
End Sub
'Neue Autoformat-Prozedur
Option Explicit
Private objWks As Worksheet, lngSpalte As Long, SpalteLast As Long
'usw ggf. weiter Variablen Anlegen
Private FarbeN As Long ' Farbe restliche Tage im Kalender
Private strMark As String 'optionaler Markierungstext in Zellen
Sub Autoformat(wks As Worksheet, Startvar As Date, _
Zeile As Long, zeileDatum As Long, spalteDatum1 As Long, arrTage, arrFarben, _
Optional GrundFarbe As Long = 2, Optional strMarkierung As String = "o")
Dim Zelle As Range, AktDatevar As Date, Spalte As Long, bolGefunden As Boolean
Dim Tag As Long, FarbeTag As Long, intI As Integer, bolFaerben As Boolean
'wks = Tabellenblatt in dem Formatierung ausgeführt werden soll
'Startvar = Startdatum der Aktivität
'Zeile = Zeile in der Startdatum geändert wurde
'zeileDatum = Zeile mit den Datumswerten
'spalteDatum1 = Spalte mit 1. Datum in Zeile "zeileDatum"
'arrTage = Array mit den zu markierenden Tagen Array(1, 2, 7, 10, 11, 12)
'arrFarben = Array mit den Farben der markierenden Tage Array(3, 4, 6, 5, 7, 19)
'GrundFarbe = Farbe für restliche Tage im Kalender, VorrgabeWert = 2
'strMarkierung = 'optionaler Markierungstext in Zellen, VorrgabeWert = "o"
'Werte die auch in NextWorkDay benutzt werden
FarbeN = GrundFarbe 'hellbeige -Farbe restliche Tage im Kalender
strMark = strMarkierung 'optionaler Markierungstext in Zellen
Set objWks = wks
With wks
'Spalte mit Start-Datum suchen
SpalteLast = IIf(IsEmpty(.Cells(zeileDatum, .Columns.Count)), _
.Cells(zeileDatum, .Columns.Count).End(xlToLeft).Column, .Columns.Count)
For Spalte = spalteDatum1 To SpalteLast
'Vergleichsdatum einlesen
AktDatevar = .Cells(zeileDatum, Spalte).Value
If Startvar = AktDatevar Then
lngSpalte = Spalte
bolGefunden = True: Exit For
Else
'Zelle formatieren, leeren
With .Cells(Zeile, Spalte)
.Interior.ColorIndex = FarbeN
.ClearContents
End With
End If
Next
If bolGefunden = True Then
'Tage ab Starttag markieren, Wochenende und Feiertage werden dabei übersprungen
'Starttag markieren
For Tag = 1 To arrTage(UBound(arrTage))
'Vergleich mit Tage-Array
FarbeTag = FarbeN
bolFaerben = False
For intI = LBound(arrTage) To UBound(arrTage)
If arrTage(intI) = Tag Then
FarbeTag = arrFarben(intI)
bolFaerben = True
Exit For
End If
Next
If bolFaerben = True Then
Call nextWorkday(Zeile, zeileDatum, FarbeTag, strMark)
Else
Call nextWorkday(Zeile, zeileDatum, FarbeN, "")
End If
If lngSpalte = SpalteLast Then Exit For
lngSpalte = lngSpalte + 1
Next
If lngSpalte = SpalteLast Then Exit Sub
'Restliche Spalten markieren
If lngSpalte