Anfangwertsuche und gefundene Zeilen kopieren und

Sub Verschieben()
Dim letztezeile, i, j, k As Long
With Sheets("Quelle")  'Name Quellblatt
letztezeile = .Cells(.Rows.Count, 1).End(xlUp).Row   'Spalte (hier A = 1) ggf. anpassen
End With
For i = 2 To letztezeile  'Schleife Quelle, beginnt bei Zeile 2
For j = 1 To 10       'Schleife Ziel, Spalte A bis J (1 bis 10), dort stehen die ersten  _
drei Zahlen als Überschrift in Zeile 1
If Val(Left(Sheets("Quelle").Cells(i, 1), 3)) = Sheets("Ziel").Cells(1, j) Then   'Name  _
Zielblatt = "Ziel"
With Sheets("Ziel")
.Cells((.Cells(.Rows.Count, j).End(xlUp).Row) + 1, j) = Sheets("Quelle").Cells(i, 1) _
_
_
_
_
_
End With
Sheets("Quelle").Cells(i, 1).ClearContents
End If
Next j
Next i
For k = letztezeile To 2 Step -1
If Sheets("Quelle").Cells(k, 1) = "" Then
Sheets("Quelle").Rows(k).Delete
End If
Next k
End Sub