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, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23) ' Kalenderspalten (Monate)
' Alte Einträge löschen
Range("B3:B33,D3:D33,F3:F33,H3:H33,J3:J33,L3:L33").ClearContents ' alte Einträge löschen (1. Halbjahr)
Range("N3:N33,P3:P33,R3:R33,T3:T33,V3:V33,X3:X33").ClearContents ' alte Einträge löschen (2. Halbjahr)
Range("A3:X33").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
|
