die mit dem hilfe braucht nochmal welche

Private Sub Button_Click()
Application.ScreenUpdating = False
Dim rngFind As Range
Dim strFind As String
Dim iRow As Integer
'Hier hinter what entsprechend modifizieren...
Set rngFind = Cells.Find(what:="3", after:=ActiveCell, LookIn:=xlValues, lookat:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rngFind Is Nothing Then
firstaddress = rngFind.Address
Do
Set rngFind = Cells.FindNext(rngFind)
If rngFind Is Nothing Then
MsgBox "Daten wurden nicht gefunden!"
Exit Sub
End If
rngFind.EntireRow.Select
'Hier anstatt Tabelle2 dein Blatt angeben, wohin übertragen werden soll...
'natürlich die anderen Einträge ebenfalls anpassen...
With Worksheets("Sheet2")
iRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveCell.EntireRow.Copy Worksheets("Sheet2").Rows(iRow)
.Columns.AutoFit
End With
Loop While Not rngFind Is Nothing And rngFind.Address <> firstaddress
End If
Worksheets("Sheet2").Activate
Application.ScreenUpdating = True
End Sub