AW: Urlaubstage in Monatsblätter eintragen
06.01.2024 17:37:03
Peer
Ergänzung...
Ich glaube, ich habe den Fehler gefunden...
mitSheets.Add after:=Worksheets(Mon)
läuft der Code durch.
Interessant, was passiert.
Aber mein Kalender ist so aufgebaut...Sub Neues_Jahr(control As IRibbonControl)
Dim lngYear As Long, lngMonth As Long, lngDay As Long
Dim datDay As Date, varFerien As Variant, varFeiertage As Variant, strFeiertag As String
Dim bolHolyday As Boolean
Dim wks As Worksheet
'On Error GoTo ERRORHANDLER
With Application
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
If MsgBox("Möchtest du wirklich das komplette Jahr löschen?" & vbCrLf _
& "Damit gehen alle Einträge verloren.", vbYesNo + vbQuestion, "Aktuelles Jahr löschen") = vbYes Then
frm_Jahr.Show
Application.Calculate
lngYear = Sheets("Gesamtstunden").Range("B25")
For lngMonth = 1 To 12
ThisWorkbook.Names.Item(MonthName(lngMonth)).RefersTo = Array(False, False, False, False)
'Set wks = Sheets(Format(DateSerial(lngYear, lngMonth, 1), "mmmm"))
With Worksheets(MonthName(lngMonth))
.Unprotect
' ' Jahr in F4 eintragen
' .Range("F4") = lngYear
' ' Monat in E4 eintragen
' .Range("E4") = Month(.Range("B12"))
'Zellen leeren und Formate entfernen
With .Range("B12:C42")
.ClearContents
.Font.ColorIndex = xlAutomatic
.Font.Bold = False
.Interior.ColorIndex = xlNone
.ClearComments
End With
.Range("D12:E42,G12:L42,P12:U42,X12:X42,Z12:AL42,BK12:BK42").ClearContents
.Range("V10:W43").Interior.ColorIndex = 15
'vom 1.Tag des Monats bis zum letzten
For lngDay = 1 To Day(DateSerial(lngYear, lngMonth + 1, 0))
'Datum ermitteln
datDay = DateSerial(lngYear, lngMonth, lngDay)
'In 'Feietage' das Datum suchen
With Sheets("Feiertage").Range("Feiertage") '??? Leerzeichen am Ende vom Bereichsnamen ??
varFeiertage = Application.Match(CLng(CDate(datDay)), .Columns(2), 0)
If IsNumeric(varFeiertage) Then
'Tag ist Feiertag
strFeiertag = .Cells(varFeiertage, 1).Text
Else
'Tag ist kein Feiertag
strFeiertag = ""
End If
End With
'In 'Ferien' das Datum suchen - kleiner oder gleich
varFerien = Application.Match(CLng(datDay), _
Sheets("Ferien").Range("Bayern").Columns(1), 1)
bolHolyday = False
'Wenn Datum gefunden, dann vergeichen ob das Enddatum auch im Bereich liegt
If IsNumeric(varFerien) Then
bolHolyday = Sheets("Ferien").Range("Bayern").Cells(varFerien, 2) >= datDay
End If
'Die Datumszellen
With .Range(.Cells(lngDay + 11, 2), .Cells(lngDay + 11, 3))
.Value = datDay 'Datum eintragen
'Wenn Wochentag größer Freitag, dann rote Schriftfarbe
If Weekday(datDay, vbMonday) > 5 Or IsNumeric(varFeiertage) Then .Font.ColorIndex = 3
'Wenn Wochentag ist Sonntag oder es ist ein Feiertag, dann Fettschrift
.Font.Bold = Weekday(datDay, vbMonday) = 7 Or IsNumeric(varFeiertage)
'Wenn Datum innerhalb eines Ferienbereiches liegt, dann Hintergrund Hellgrün
If bolHolyday Then .Interior.Color = RGB(235, 241, 222)
'Wenn Datum ein Feiertag, dann Kommentar in Spalte B
If strFeiertag > "" Then
With .Range("A1")
'.Interior.Color = RGB(255, 255, 153) 'helles gelb
.AddComment strFeiertag
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Shape.Fill.Transparency = 0 'ohne Transparenz
.Comment.Shape.Fill.ForeColor.RGB = RGB(204, 255, 204) 'Hintergrundfarbe green
End With
End If
End With
Next
'.Range("V10:W43").Locked = True
.Protect
End With
Next
gobjRibbon.Invalidate
ActiveWorkbook.Protect
Sheets("Januar").Select
Range("D12").Select
ErrorHandler:
'If Err.Number > 0 Then
' MsgBox "Fehler in con_Jahr_neu" & vbLf & vbLf & "Prozedur:" & vbTab & "Neues_Jahr" & vbLf & _
' "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _
' IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!"
' Err.Clear
'End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
Else: Exit Sub
End If
End Sub
Dabei sind die Monatsblätter schon vorhanden und es werden nur die "Daten" aktualisiert.
Der Code ist im Großen und ganze nicht auf meinem Mist gewachsen. Ein wenig aus dem Archiv und Anpassungen von einigen Helfern hier und ein wenig von mir.
Aber schlussendlich habe ich immer noch keine Lösung für das "Urlaubs-Problem".
Peer
