Hi Daniel,
das ging schneller als erwartete.
Vielen Dank!!!!
Hier noch der Code des Kalender für die Schaltjahre.
Wenn du das noch löst wäre ich dir mehr als Dankbar.
Habe diesen Code auch nicht komplett selbst geschrieben, habe aber einen Abgabetermin. :D
Public Sub Kalender_erstellen(Startposition As Range, A_datum As Date, E_datum As Date, _
Feiertage As Boolean _
, Sa As Boolean, So As Boolean, zeilen_nachunten As Integer, _
Spaltenbreite As Integer, Tage_ein_zweistellig As Boolean, _
KW_ein_zweistellig As Boolean, Farbe_rahmenlinie As Integer _
, zeilenhöhe As Integer)
Dim a As Date
Dim spalte As Integer
Dim zeile As Integer
Dim Pos1_kw As Integer
Dim Pos2_kw As Integer
Dim Pos1_mon As Integer
Dim Pos2_mon As Integer
spalte = Startposition.Column
zeile = Startposition.Row
With Cells.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With ThisWorkbook.ActiveSheet
' Formatierungen
.Range(Cells(zeile + 3, spalte), Cells(zeile + 3, spalte + (E_datum - A_datum))). _
ColumnWidth = Spaltenbreite
With .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte + ( _
E_datum - A_datum)))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
' Von A_datum bis E_datum
For a = A_datum To E_datum
' Formatierung wenn Datum ist ein SA oder So oder Feiertag
If Sa = True Then
If Format(a, "ddd") = "Sa" Then _
.Range(Cells(zeile + 2, spalte), Cells(zeile + zeilen_nachunten + 1994, spalte)) _
.Interior.ColorIndex = 8
End If
If So = True Then
If Format(a, "ddd") = "So" Then _
.Range(Cells(zeile + 2, spalte), Cells(zeile + zeilen_nachunten + 1994, spalte)) _
.Interior.ColorIndex = 8
End If
If Feiertage = True Then
If Ist_feiertag(a) "" Then
.Range(Cells(zeile + 2, spalte), Cells(zeile + zeilen_nachunten + 1994, spalte)). _
Interior.ColorIndex = 8
' Feiertags - kommentar einfügen
Call Kommentar_formatieren(Cells(zeile + 3, spalte), Ist_feiertag(a))
End If
End If
' Kalenderwoche
If Format(a, "ddd") = "Mo" Then Pos1_kw = Cells(zeile + 1, spalte).Column
If Format(a, "ddd") = "Fr" Then Pos2_kw = Cells(zeile + 1, spalte).Column
If Format(a, "ddd") = "Fr" And Pos1_kw 0 Then
.Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)).Merge
If KW_ein_zweistellig = True Then
.Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)).NumberFormat = "@"
.Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)) = Format( _
kalenderwoche_D(a), "##00")
Else
.Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)) = Format( _
kalenderwoche_D(a), "#0")
End If
Pos1_kw = 0
End If
' Monat
If Day(a) = 1 Then
Pos1_mon = Cells(zeile, spalte).Column
.Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 1994, spalte)). _
Borders(xlEdgeLeft).LineStyle = xlThin
End If
If Day(a) = Letzter_tag_im_monat(a) Then
Pos2_mon = Cells(zeile, spalte).Column
.Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 1994, spalte)). _
Borders(xlEdgeRight).LineStyle = xlThin
End If
If Day(a) = Letzter_tag_im_monat(a) And Pos1_mon 0 Then
.Range(Cells(zeile, Pos1_mon), Cells(zeile, Pos2_mon)).Merge
.Range(Cells(zeile, Pos1_mon), Cells(zeile, Pos2_mon)) = Format(a, "mmmm")
Pos1_mon = 0
End If
' Tag zahl z.b. 6 oder 06
If Tage_ein_zweistellig = True Then
.Cells(zeile + 3, spalte).NumberFormat = "@"
.Cells(zeile + 3, spalte) = Format(a, "dd")
Else
.Cells(zeile + 3, spalte) = Format(a, "d")
End If
' Tag wochentag c.b. Mo
.Cells(zeile + 2, spalte) = Format(a, "ddd")
spalte = spalte + 1
Next a
End With
Application.ScreenUpdating = True
End Sub
Function Ostern(Yr As Integer) As Date
Dim D As Integer
D = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
Ostern = DateSerial(Yr, 3, 1) + D + (D > 48) + 6 - _
((Yr + Yr \ 4 + D + (D > 48) + 1) Mod 7)
End Function
Public Function Ist_feiertag(datum As Date) As String
Ist_feiertag = ""
' Ostern
If datum = Ostern(Year(datum)) Then Ist_feiertag = Ist_feiertag & "Ostern" & Chr(10)
' Neujahr
If datum = DateSerial(Year(datum), 1, 1) Then Ist_feiertag = Ist_feiertag & "Neujahr" & Chr( _
10)
' Karfreitag
If datum = Ostern(Year(datum)) - 2 Then Ist_feiertag = Ist_feiertag & "Karfreitag" & Chr(10) _
' Ostermontag
If datum = Ostern(Year(datum)) + 1 Then Ist_feiertag = Ist_feiertag & "Ostermontag" & Chr( _
10)
' Christi Himmelfahrt
If datum = Ostern(Year(datum)) + 39 Then Ist_feiertag = Ist_feiertag & "Christi Himmelfahrt" _
& Chr(10)
' Pfingstmontag
If datum = Ostern(Year(datum)) + 50 Then Ist_feiertag = Ist_feiertag & "Pfingstmontag" & _
Chr(10)
' Fronleichnam
If datum = Ostern(Year(datum)) + 60 Then Ist_feiertag = Ist_feiertag & "Fronleichnam" & Chr( _
10)
' TagDeutscheEinheit
If datum = DateSerial(Year(datum), 10, 3) Then Ist_feiertag = Ist_feiertag & "Tag der _
Deutschen Einheit" & Chr(10)
' Heiligabend
If datum = DateSerial(Year(datum), 12, 24) Then Ist_feiertag = Ist_feiertag & "Heiligabend" _
& Chr(10)
' 1. Weihnachtsfeiertag
If datum = DateSerial(Year(datum), 12, 25) Then Ist_feiertag = Ist_feiertag & "1. _
Weihnachtsfeiertag" & Chr(10)
' 2. Weihnachtsfeiertag
If datum = DateSerial(Year(datum), 12, 26) Then Ist_feiertag = Ist_feiertag & "2. _
Weihnachtsfeiertag" & Chr(10)
' Silvester
If datum = DateSerial(Year(datum), 12, 31) Then Ist_feiertag = Ist_feiertag & "Silvester" & _
Chr(10)
If Ist_feiertag "" Then Ist_feiertag = Left(Ist_feiertag, Len(Ist_feiertag) - 1)
End Function
Function kalenderwoche_D(datum As Date) As Integer
Dim t As Date
t = DateSerial(Year(datum + (8 - Weekday(datum)) Mod 7 - 3), 1, 1)
kalenderwoche_D = (datum - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function
Public Function Letzter_tag_im_monat(datum As Date) As Integer
Letzter_tag_im_monat = Day(DateSerial(Year(datum), Month(datum) + 1, "01") - 1)
End Function
Sub Kommentar_formatieren(Bereich As Range, Text As String)
With Bereich
.ClearComments
.AddComment.Text Text:=Text
.Comment.Visible = False
.Comment.Shape.TextFrame.AutoSize = True
.Comment.Shape.TextFrame.HorizontalAlignment = xlCenter
.Comment.Shape.TextFrame.Characters.Font.Name = "Tahoma"
.Comment.Shape.TextFrame.Characters.Font.size = 9
End With
End Sub