Sub Nikolas()
Dim Z1 As Integer, LR As Integer, LC As Integer, SpD As Integer, SpK As Integer
Dim D As Variant, Zeile As Integer, Datum As Date, TTag As Integer
Dim AP As String, WT As Integer, BelTage As String, i As Integer
SpD = 2
Z1 = 1
With Sheets("Tabelle1")
LR = .Cells(.Rows.Count, SpD).End(xlUp).Row
LC = .Cells(Z1, .Columns.Count).End(xlToLeft).Column
If LR <= Z1 Then
MsgBox "Keine Eintäge vorhanden"
Exit Sub
End If
For Each D In Columns(SpD).SpecialCells(xlCellTypeConstants, 1)
Zeile = D.Row
Datum = D.Value
AP = "AP" & .Cells(Zeile, 1)
If WorksheetFunction.CountIf(.Rows(Z1), Datum) = 0 Then
MsgBox "Datum: " & Datum & " nicht gefunden"
Else
For i = 1 To 7
If .Cells(Zeile, SpD + i) = "x" Then
BelTage = BelTage & i & ", "
End If
Next
SpK = WorksheetFunction.Match(CDbl(Datum), .Rows(Z1), 0)
For TTag = SpK To LC
WT = Weekday(.Cells(Z1, TTag), vbMonday)
If InStr(BelTage, WT) > 0 Then
.Cells(Zeile, TTag) = AP
Else
.Cells(Zeile, TTag).ClearContents
End If
Next
End If
Next
End With
End Sub