Hallo, 

wäre für eure Hlfe sehr dankbar. Bin Anfänger.

Der nachfolgende VBA Code liest zwar die Daten aus, schreibt mir aber alles untereinander, anstatt
die entsprechden Daten in die gleiche Zeile.

Ich muss aus einer Exceltabelle aus den Zeilen 14 bis 21 die Spalte A (Ist Text) auslesen und die gesamte Zeile prüfen,
ob Zellen blau eingefäbt sind. Es geht um eine Timingliste wo die KWs blau eingefärbt sind. 
Bei blau eingefärbten Zellen dann in Zeile 3 die Entsprechend KW ermitteln

Nun möchte ich erreichen, dass ab Zeile 50 die Daten aus Zeile 14 stehen und aus Zeile 15 die Daten auf Zeile 51 usw. usw.

Momenta werden zwar die Daten ermittel, aber in meinen Zelle ab Zeile 50, wird alles zu Text aus Zeile 14 aufgelistet. Also so

Text Zeile 14   22
Text Zeile 14        23
Text Zeile 14                25 usw.
 

Richtg wäre 
Text Zeile 14   22  23
Text Zeile 15   25 
Text Zeile 16   27         29  usw.

Ohje, ich hoffe ich konnte es halbwegs verständlich schildern.

LG Reinhold

Sub SucheKalenderwoche()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim kalenderwoche As Long
Dim outputRow As Long

Set ws = ThisWorkbook.Sheets("Timingeins") ' Ersetze "DeinBlattName" durch den Namen deines Blatts
Set rng = ws.Range("14:21") ' Die zu überprüfende Zeile 14
outputRow = 50 ' Zeile, in der die Kalenderwochen ausgegeben werden sollen

' Loop durch jede Zelle in der Zeile
For Each cell In rng
    ' Überprüfe die Farbe der Zelle (Blau - Farbcode 33)
    If cell.Interior.Color = RGB(0, 176, 240) Then
        ' Wenn die Zelle blau ist, ermittel die Kalenderwoche aus Zeile 3
        kalenderwoche = ws.Cells(3, cell.Column).Value

        ' Gib den Text aus Zelle A14 in Zeile 50, Spalte A, aus
        ws.Cells(outputRow, "A").Value = ws.Cells(14, "A").Value

        ' Gib die ermittelte Kalenderwoche in der gewünschten Zeile aus (ab Zeile 50)
        ws.Cells(outputRow, cell.Column).Value = kalenderwoche

        ' Inkrementiere die Ausgabezeile für die nächste gefundene Kalenderwoche
        outputRow = outputRow + 1
    End If
Next cell

' Zusätzliche Schleife, um die Zeilen 15 bis 21 einzutragen
For i = 14 To 21
    ' Gib den Text aus Zelle A15 bis A21 in Zeile 50 und folgenden Zeilen in Spalte A aus
    ws.Cells(outputRow, "A").Value = ws.Cells(i, "A").Value

    ' Inkrementiere die Ausgabezeile für die nächste Zeile
    outputRow = outputRow + 1
Next i
End Sub