Option
Explicit
Sub
SucheKalenderwoche()
Const
OutputRow
As
Long
= 50
Dim
ws
As
Worksheet
Dim
rng
As
Range
Set
ws = ThisWorkbook.Worksheets(
"Timingeins"
)
Set
rng = ws.Rows(
"14:21"
)
Dim
rngRow
As
Excel.Range
Dim
rngCell
As
Excel.Range
For
Each
rngRow
In
rng.Rows
ws.Cells(OutputRow + rngRow.Row - rng.Row,
"A"
).Value = ws.Cells(rngRow.Row,
"A"
).Value
For
Each
rngCell
In
rngRow.Cells
If
rngCell.Interior.Color = RGB(0, 176, 240)
Then
ws.Cells(OutputRow + rngCell.Row - rng.Row, rngCell.Column).Value = ws.Cells(3, rngCell.Column).Value
End
If
Next
Next
End
Sub