Hallo zusammen,

ich habe in einem Forum eine für mich passende automatische Kalendererstellung gefunden. Soweit habe ich schon einiges für mich angepasst.

Ich habe auf meiner Übersichtsseite einen Button erstellt. Dieser erstellt mir ein neues Tabellenblatt und führt den unten ausgeführten Code aus.

Da ich das Datum nicht immer im Code anpassen möchte, würde ich das Datum gerne auch auf der Übersichtsseite haben. 

In Zelle A9 und B9

In Zelle A10 und B10

Wenn das Datum drinne steht, soll dieses in den Code übernommen werden.

Public Sub Erstellen()
    Call Kalender_erstellen(ActiveSheet.Range("B1"), "01.01.16", "30.06.2016", True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)
    Call Kalender_erstellen(ActiveSheet.Range("B16"), "01.07.16", "31.12.16", True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)

Für eure Hilfe wäre ich sehr dankbar :-).

Liebe Grüße

Option Explicit

Public Sub Erstellen()
    Call Kalender_erstellen(ActiveSheet.Range("B1"), "01.01.16", "30.06.2016", True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)
    Call Kalender_erstellen(ActiveSheet.Range("B16"), "01.07.16", "31.12.16", True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)
End Sub

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, _
                              Farbe_sa As Integer, Farbe_so As Integer, Farbe_feiertag 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
    Dim b As Range
    spalte = Startposition.Column
    zeile = Startposition.Row
    Application.ScreenUpdating = False
    With ThisWorkbook.ActiveSheet
    ' Schauen ob in dem Bereich etwas steht
    For Each b In .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte + (E_datum - A_datum)))
    If b <> "" Then
    Application.ScreenUpdating = True
    .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte + (E_datum - A_datum))).Select
    MsgBox "Achtung in dem Bereich in dem der Kalender erstellt werden soll sind nicht alle zellen leer!", vbCritical, "Achtung"
    Exit Sub
    End If
    Next b
        ' 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)))
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
                .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                .Borders.ColorIndex = Farbe_rahmenlinie
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .RowHeight = zeilenhöhe
                .Borders.LineStyle = xlContinuous
                .Borders.Weight = xlThin
        End With
        .Range(Cells(zeile + 1, spalte), Cells(zeile + 1, spalte + (E_datum - A_datum))).Borders(xlInsideVertical).LineStyle = xlNone
        ' 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 + 1, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Interior.ColorIndex = Farbe_sa
            End If
            If So = True Then
            If Format(a, "ddd") = "So" Then _
                .Range(Cells(zeile + 1, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Interior.ColorIndex = Farbe_so
            End If
            If Feiertage = True Then
            If Ist_feiertag(a) <> "" Then
            .Range(Cells(zeile + 2, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Interior.ColorIndex = Farbe_feiertag
            ' 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 + 3, spalte)).Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Borders(xlEdgeLeft).Weight = xlThick
            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 + 3, spalte)).Borders(xlEdgeRight).LineStyle = xlContinuous
            .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Borders(xlEdgeRight).Weight = xlThick
            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)
    ' Maifeiertag
    If Datum = DateSerial(Year(Datum), 5, 1) Then Ist_feiertag = Ist_feiertag & "Maifeiertag" & 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)
    ' Pfingstsonntag
    If Datum = Ostern(Year(Datum)) + 49 Then Ist_feiertag = Ist_feiertag & "Pfingstsonntag" & 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)
    ' Tag der Arbeit
    If Datum = DateSerial(Year(Datum), 5, 1) Then Ist_feiertag = Ist_feiertag & "Tag der Arbeit" & Chr(10)
    ' Reformationstag
    If Datum = DateSerial(Year(Datum), 10, 31) Then Ist_feiertag = Ist_feiertag & "Reformationstag" & 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)
    ' Mariä Himmelfahrt
    'If Datum = DateSerial(Year(Datum), 8, 15) Then Ist_feiertag = Ist_feiertag & "Maria Himmelfahrt" & Chr(10)
    ' Buß- und Bettag
    'If Datum = CDate("25.12." & Year(Datum)) - Weekday("25.12." & Year(Datum), vbMonday) - 32 Then Ist_feiertag = Ist_feiertag & "Buß- und Bettag" & Chr(10)
    ' Weiberfastnacht
    'If Datum = Ostern(Year(Datum)) - 52 Then Ist_feiertag = Ist_feiertag & "Weiberfastnacht" & Chr(10)
    ' Rosenmontag
    'If Datum = Ostern(Year(Datum)) - 48 Then Ist_feiertag = Ist_feiertag & "Rosenmontag" & 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
    ''von Christoph Kremer, Aachen
    'Berechnt die KW nach DIN 1355
    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