Feiertage in Urlaubsplaner eintragen

Mit diesem Makro können Feiertage als Kommentarfelder in den Urlaubsplaner eingefügt werden. Sie werden als kleines Kommentarfeld angezeigt. Der Urlaubsplaner befindet sich im Downloadbereich unter Beispieltabellen (Excel).

Option Explicit

Sub feiertage()
' Schreibt Feiertage in Kommentarfenster
' Ergänzung für Urlaubs- und Abwesenheitsplaner
' Klaus-Dieter Oppermann
' letzter Stand 31.07.2009 (Makro optimiert)
Dim sp As Integer
Dim r As Integer
Dim f As Integer
Dim s As Integer
Dim adr As String
Dim tg(300) As Long
Dim ft(300) As String
Dim ws(2) As String
Dim intSp As Integer
Dim rngBereich As Range
Dim Zahl As Long
    ws(1) = "1. Halbjahr"
    ws(2) = "2. Halbjahr"
    ' Feiertage einlesen
    For r = 4 To Worksheets("Bitte lesen").Range("A65536").End(xlUp).Row
        tg(r) = Worksheets("Bitte lesen").Cells(r, 2)
        ft(r) = Worksheets("Bitte lesen").Cells(r, 1)
    Next r
    ' alte Kommentare löschen
    For s = 1 To 2
        Worksheets(ws(s)).Activate
        Worksheets(ws(s)).Range("B3:GC3").Select
        Application.DisplayCommentIndicator = xlCommentIndicatorOnly
        Application.DisplayCommentIndicator = xlCommentAndIndicator
        Selection.ClearComments
        Worksheets(ws(s)).Cells(1, 1).Select
    Next s
    ' Ende löschen
    ' Feiertage in Kommentarfenster eintragen
    For f = 4 To r - 1
        If Month(CDate(tg(f))) < 7 Then s = 1 Else s = 2
        Worksheets(ws(s)).Activate
        Set rngBereich = Worksheets(ws(s)).Range("B3:GC3")
        Set rngBereich = Worksheets(ws(s)).Range("B3", rngBereich)
        intSp = Application.Match(tg(f), rngBereich, 0) + 1
        If IsNumeric(intSp) Then
            Worksheets(ws(s)).Cells(3, intSp).AddComment
            Worksheets(ws(s)).Cells(3, intSp).Comment.Visible = True
            Worksheets(ws(s)).Cells(3, intSp).Comment.Shape.Select True
            Worksheets(ws(s)).Cells(3, intSp).Comment.Text Text:="" & Chr(10) & ft(f) & Chr(10) & ""
            Selection.HorizontalAlignment = xlCenter
            Selection.ShapeRange.Fill.ForeColor.SchemeColor = 11
            Selection.ShapeRange.Fill.Visible = msoTrue
            Selection.ShapeRange.Fill.Solid
            Selection.Font.ColorIndex = 3
            Selection.Font.Bold = True
            Selection.ShapeRange.ScaleHeight 0.51, msoFalse, msoScaleFromTopLeft
            Worksheets(ws(s)).Cells(3, intSp).Comment.Shape.Select True
            Worksheets(ws(s)).Cells(3, intSp).Comment.Visible = False
            Worksheets(ws(s)).Cells(1, 1).Select
        End If
    Next f
End Sub