Hallo Steffen,
hier das überarbeitete Makro:
Sub Spalte1_Ferien_Feiertage()
Application.ScreenUpdating = False
'
' Spalte3 Veranstaltungen + Feiertage löschen
'
Sheets("Monate").Select
Range("E4:E34").Select
Dim i As Integer
For i = 0 To 11
Selection.ClearContents
With Selection
End With
With Selection.Font
.Name = "Calibri"
.Size = 8
.Color = Black
End With
ActiveCell.Offset(0, 6).Range("A1:A31").Select
Next i
'
' Spalte2 und dann 3 ROTE Farbe löschen - So bleibt wegen =WOCHENTAG(A4;2)=7
'
Sheets("Monate").Select
Range("C4:C34").Select
For i = 0 To 11
With Selection.Font
.Color = Black
End With
ActiveCell.Offset(0, 6).Range("A1:A31").Select
Next i
Range("D4:D34").Select
For i = 0 To 11
With Selection.Font
.Color = Black
End With
ActiveCell.Offset(0, 6).Range("A1:A31").Select
Next i
'
' eintragen beginnen
'
Dim SuchDatum As Date
Dim i_Zeile As Integer
Dim i_Spalte As Integer
Dim i_Zaehler As Integer
Dim VaMatch As Variant
Dim Feiertagstext As String
Dim arrVeranstaltungen As Variant
Dim strVeranstaltung As String
'
' Spalte3 Feiertage 1 (rot)
'
For i_Spalte = 3 To 72 Step 6
For i_Zeile = 4 To 34 Step 1
Sheets("Monate").Select
ActiveSheet.Cells(i_Zeile, i_Spalte).Select
SuchDatum = Selection.Value
Sheets("Daten").Select
If Not IsError(Application.Match(CLng(SuchDatum), Range("G5:G12"), 0)) Then
VaMatch = Application.Match(CLng(SuchDatum), Range("G5:G12"), 0)
Range("G5:G5").Select
ActiveCell.Offset(VaMatch - 1, -5).Range("A1").Select
Feiertagstext = Selection.Value
Sheets("Monate").Select
ActiveCell.Offset(0, 2).Range("A1:A1").Select
ActiveCell.FormulaR1C1 = ActiveCell.FormulaR1C1 + " " + Feiertagstext
Selection.Font.Color = -16776961 'rot
ActiveCell.Offset(0, -1).Range("A1:A1").Select
Selection.Font.Color = -16776961 'rot
ActiveCell.Offset(0, -1).Range("A1:A1").Select
Selection.Font.Color = -16776961 'rot
End If
Next i_Zeile
Next i_Spalte
'
' Spalte3 Feiertage 2 (rot Sonntag)
'
For i_Spalte = 3 To 72 Step 6
For i_Zeile = 4 To 34 Step 1
Sheets("Monate").Select
ActiveSheet.Cells(i_Zeile, i_Spalte).Select
SuchDatum = Selection.Value
Sheets("Daten").Select
If Not IsError(Application.Match(CLng(SuchDatum), Range("G15:G24"), 0)) Then
VaMatch = Application.Match(CLng(SuchDatum), Range("G15:G24"), 0)
Range("G15:G15").Select
ActiveCell.Offset(VaMatch - 1, -5).Range("A1").Select
Feiertagstext = Selection.Value
Sheets("Monate").Select
ActiveCell.Offset(0, 2).Range("A1:A1").Select
ActiveCell.FormulaR1C1 = ActiveCell.FormulaR1C1 + " " + Feiertagstext
Selection.Font.Color = -16776961 'rot
End If
Next i_Zeile
Next i_Spalte
'
' Spalte3 Feiertage 3 (schwarz)
'
For i_Spalte = 3 To 72 Step 6
For i_Zeile = 4 To 34 Step 1
Sheets("Monate").Select
ActiveSheet.Cells(i_Zeile, i_Spalte).Select
SuchDatum = Selection.Value
Sheets("Daten").Select
If Not IsError(Application.Match(CLng(SuchDatum), Range("G27:G32"), 0)) Then
VaMatch = Application.Match(CLng(SuchDatum), Range("G27:G32"), 0)
Range("G27:G27").Select
ActiveCell.Offset(VaMatch - 1, -5).Range("A1").Select
Feiertagstext = Selection.Value
Sheets("Monate").Select
ActiveCell.Offset(0, 2).Range("A1:A1").Select
ActiveCell.FormulaR1C1 = ActiveCell.FormulaR1C1 + " " + Feiertagstext
End If
Next i_Zeile
Next i_Spalte
'
' Spalte3 Feiertage 4 (rot)
'
For i_Spalte = 3 To 72 Step 6
For i_Zeile = 4 To 34 Step 1
Sheets("Monate").Select
ActiveSheet.Cells(i_Zeile, i_Spalte).Select
SuchDatum = Selection.Value
Sheets("Daten").Select
If Not IsError(Application.Match(CLng(SuchDatum), Range("G35:G46"), 0)) Then
VaMatch = Application.Match(CLng(SuchDatum), Range("G35:G46"), 0)
Range("G35:G35").Select
ActiveCell.Offset(VaMatch - 1, -5).Range("A1").Select
Feiertagstext = Selection.Value
Sheets("Monate").Select
ActiveCell.Offset(0, 2).Range("A1:A1").Select
ActiveCell.FormulaR1C1 = ActiveCell.FormulaR1C1 + " " + Feiertagstext
Selection.Font.Color = -16776961 'rot
ActiveCell.Offset(0, -1).Range("A1:A1").Select
Selection.Font.Color = -16776961 'rot
ActiveCell.Offset(0, -1).Range("A1:A1").Select
Selection.Font.Color = -16776961 'rot
End If
Next i_Zeile
Next i_Spalte
'
' Spalte3 Feiertage 5 (schwarz)
'
For i_Spalte = 3 To 72 Step 6
For i_Zeile = 4 To 34 Step 1
Sheets("Monate").Select
ActiveSheet.Cells(i_Zeile, i_Spalte).Select
SuchDatum = Selection.Value
Sheets("Daten").Select
If Not IsError(Application.Match(CLng(SuchDatum), Range("G49:G56"), 0)) Then
VaMatch = Application.Match(CLng(SuchDatum), Range("G49:G56"), 0)
Range("G49:G49").Select
ActiveCell.Offset(VaMatch - 1, -5).Range("A1").Select
Feiertagstext = Selection.Value
Sheets("Monate").Select
ActiveCell.Offset(0, 2).Range("A1:A1").Select
ActiveCell.FormulaR1C1 = ActiveCell.FormulaR1C1 + " " + Feiertagstext
End If
Next i_Zeile
Next i_Spalte
'Veranstaltungen in Kalender übertragen
'im Arbeitsblatt Daten in Spalte N die Einträge mit Datum zählen
With Worksheets("Daten")
For i_Zeile = 5 To .Cells(Rows.Count, 14).End(xlUp).Row
If IsDate(.Cells(i_Zeile, 14).Value) = True Then i_Zaehler = i_Zaehler + 1
Next i_Zeile
'Array für Veranstaltungen redimensionieren
'0 = Datum, 1 = Veranstaltung
ReDim arrVeranstaltung(i_Zaehler, 1)
'Variable für Zähler wieder zurücksetzen
i_Zaehler = 0
'nun Spalte N noch einmal durchlaufen und Daten einlesen
For i_Zeile = 5 To .Cells(Rows.Count, 14).End(xlUp).Row
If IsDate(.Cells(i_Zeile, 14).Value) = True Then
i_Zaehler = i_Zaehler + 1
arrVeranstaltung(i_Zaehler, 0) = .Cells(i_Zeile, 14).Value 'Daten aus Spalte N - Datum
arrVeranstaltung(i_Zaehler, 1) = .Cells(i_Zeile, 9).Value 'Daten aus Spalte i - Text
End If
Next i_Zeile
End With
With Worksheets("Monate")
'Spalten mit Kalender durchlaufen
For i_Spalte = 3 To 72 Step 6
'Zeilen des Kalenders durchlaufen
For i_Zeile = 4 To .Cells(Rows.Count, i_Spalte).End(xlUp).Row
'Variable für Veranstaltungstext mit Inhalt der Zelle füllen
strVeranstaltung = .Cells(i_Zeile, i_Spalte + 2).Value
'Kalenderdaten mit Daten aus Array vergleichen
For i = 1 To i_Zaehler
If .Cells(i_Zeile, i_Spalte).Value = arrVeranstaltung(i, 0) Then
If strVeranstaltung = "" Then
'falls kein Text vorhanden
strVeranstaltung = strVeranstaltung & arrVeranstaltung(i, 1)
Else
'falls Text in Variable vorhanden ist
strVeranstaltung = strVeranstaltung & " " & arrVeranstaltung(i, 1)
End If
End If
Next i
.Cells(i_Zeile, i_Spalte + 2) = strVeranstaltung
Next i_Zeile
Next i_Spalte
End With
Application.ScreenUpdating = True
Sheets("Daten").Select
Range("P2:P2").Select
End Sub
Schau mal, ob das so funktioniert, wie du dir das vorstellst.
Gruß
M.O.