Sub
SucheKalenderwoche()
Dim
ws
As
Worksheet
Dim
rng
As
Range
Dim
cell
As
Range, rov
As
Range
Dim
kalenderwoche
As
Long
Dim
outputRow
As
Long
, i&, colnr&
Set
ws = ThisWorkbook.Sheets(
"Timingeins"
)
Set
rng = ws.Range(
"14:21"
)
outputRow = 50
colnr = 2
For
Each
rov
In
rng.Rows
For
Each
cell
In
rov
If
cell.Interior.Color = RGB(0, 176, 240)
Then
ws.Cells(outputRow,
"A"
).Value = rov.Cells(1).Value
ws.Cells(outputRow, colnr).Value = ws.Cells(3, cell.Column).Value
colnr = colnr + 1
End
If
Next
outputRow = outputRow + 1
Next
End
Sub