Makro zum Übertragen der Termine

Hier nun das Makro, mit dessen Hilfe die Termine in das Kalenderblatt übertragen werden. Die einzelnen Zeilen habe ich mit kurzen Komentaren versehen. Ich hoffe das ist ausreichend verständlich. Sicher ist die Gliederung in zwei Hauptbereiche (Daten einlesen und Daten in den Kalender eintragen) zu erkennen. Weiter kann man sehen, das jeder dieser Teile wieder in drei Gruppen geliedert ist: Feiertage, Geburtstage und allgemeine Termine. Grundsätzlich ist es möglich, davon nur Teilbereiche zu nutzen, zum Beispiel die Ausgabe von Geburtstagen.

Entsprechend könnten dann die nicht benötigten Bereiche im Quelltext gelöscht werden. Im Übrigen auch hier wieder der Hinweis auf den Downloadbereich, wo die komplette Tabelle auch zur Verfügung steht.

Mai 2009 - Dieses Makro habe ich völlig neu geschrieben, es ist jetzt etwas kürzer und vor allem schneller.

Option Explicit

Sub Termine_eintragen()
'trägt vorgegebene Termine in die Kalenderblätter ein
'geschrieben von Klaus-Dieter Oppermann geschrieben am 16.03.99
'Stand: 31.05.2009 Makro neu geschrieben

Dim iZei As Integer                                                     ' Zielzeile für Termin
Dim iSp As Integer                                                      ' Zielspalte für Termin (Monat)
Dim intAnz As Integer                                                   ' Schleifenzähler füt Termine
Dim iLeZeile                                                            ' Letzte Kalenderzeile
Dim varMonArr As Variant                                                ' Monatsspalten
Application.ScreenUpdating = False                                      ' Bildschirmaktualisierunng aus
varMonArr = Array(1, 4, 7, 10, 13, 16, 19, 22, 25, 28, 31, 34)          ' Kalenderspalten (Monate)
' Alte Einträge löschen
Range("B3:B33,E3:E33,H3:H33,K3:K33,N3:N33,Q3:Q33").ClearContents        ' alte Einträge löschen (1. Halbjahr)
Range("T3:T33,W3:W33,Z3:Z33,AC3:AC33,AF3:AF33,AI3:AI33").ClearContents  ' alte Einträge löschen (2. Halbjahr)
Range("A3:AU33").Font.ColorIndex = 0                                    ' schwarze Schrift
' Neue Termine eintragen

' Da der Kalender nur einen Termin pro Tag anzeigen kann, werden die Einträge in der Reihenfolge des Makros
' ggf. überschrieben. Bei Bedarf können die Blöcke Feiertage, Geburtstage und sonstige Termine ausgetauscht
' werden. Der nächste Block überschreibt die / den vorhergehenden.

' sonstige Termine eintragen
For intAnz = 3 To Sheets("Termine").Range("E2").End(xlDown).Row         ' sonstige Termine einlesen
    iSp = varMonArr(Month(Sheets("Termine").Cells(intAnz, 5)) - 1)      ' Zielspalte festlegen
    iLeZeile = Sheets("Kalender").Cells(65536, iSp).End(xlUp).Row       ' letzte gefüllte Zelle
    iZei = CInt(Application.Match(Sheets("Termine").Cells(intAnz, 5) _
    , Range(Cells(3, iSp), Cells(iLeZeile, iSp)), 0))                   ' Zielzeile berechnen
    Sheets("Kalender").Cells(iZei + 2, iSp + 1) = Sheets("Termine") _
    .Cells(intAnz, 6)                                                   ' sonstigen Termin eintragen
Next intAnz                                                             ' nächster Termin
' Feiertage eintragen
For intAnz = 3 To Sheets("Termine").Range("A2").End(xlDown).Row         ' Feiertage einlesen
    iSp = varMonArr(Month(Sheets("Termine").Cells(intAnz, 1)) - 1)      ' Zielspalte festlegen
    iLeZeile = Sheets("Kalender").Cells(65536, iSp).End(xlUp).Row       ' Letzte gefüllte Zelle
    iZei = CInt(Application.Match(Sheets("Termine").Cells(intAnz, 1) _
    , Range(Cells(3, iSp), Cells(iLeZeile, iSp)), 0))                   ' Zielzeile berechnen
    Sheets("Kalender").Cells(iZei + 2, iSp + 1) = Sheets("Termine") _
    .Cells(intAnz, 2)                                                   ' Feiertag eintragen
    Range(Sheets("Kalender").Cells(iZei + 2, iSp), Sheets("Kalender") _
    .Cells(iZei + 2, iSp + 1)).Font.ColorIndex = 3                      ' Datum und Feiertag rot färben
  Next intAnz                                                           ' nächster Feiertag
' Geburtstage eintragen
For intAnz = 3 To Sheets("Termine").Range("C2").End(xlDown).Row         ' Geburtstage einlesen
    Sheets("Termine").Cells(1, 255) = DateSerial(Sheets("Kalender") _
    .Cells(1, 1), Month(Sheets("Termine").Cells(intAnz, 3)), _
    Day(Sheets("Termine").Cells(intAnz, 3)))                            ' Geburtstag auf aktuelles Jahr umrechnen
    iSp = varMonArr(Month(Sheets("Termine").Cells(intAnz, 3)) - 1)      ' Zielspalte festlegen
    iLeZeile = Sheets("Kalender").Cells(65536, iSp).End(xlUp).Row       ' letzte gefüllte Zelle
    iZei = CInt(Application.Match(Sheets("Termine").Cells(1, 255) _
    , Range(Cells(3, iSp), Cells(33, iSp)), 0))                         ' Zielzeile berechnen
    Sheets("Kalender").Cells(iZei + 2, iSp + 1) = "Geb. " & Sheets _
    ("Termine").Cells(intAnz, 4) & " (" & DateDiff("YYYY", Sheets _
    ("Termine").Cells(intAnz, 3), DateSerial(Sheets("Kalender") _
    .Cells(1, 1), 12, 31)) & ")"                                        ' Zelleneintrag berechnen und eintragen
    Sheets("Kalender").Cells(iZei + 2, iSp + 1).Font.ColorIndex = 5     ' blaue Farbe festlegen
Next intAnz                                                             ' nächster Geburtstag
Application.ScreenUpdating = True                                       ' Bildschirmaktualisierung ein
End Sub