[b]Option Explicit

Sub Duplikate_finden_und_kopieren()
Dim rngSuchbereich As Range
Dim strAddresse As String
Dim objAktSheet As Object
Dim objNewSheet As Object
Dim varSuchtext As String

varSuchtext = InputBox("Bitte Scuchbegriff eintragen")

If varSuchtext = "" Or varSuchtext = False Then Exit Sub

'Tabellenblatt "Auswertung" löschen
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Auswertung").Delete
Application.DisplayAlerts = True
On Error GoTo 0


Set objAktSheet = ActiveSheet
'Neues Tabellenblatt mit denm Namen "Auswertung" anlegen
Set objNewSheet = Application.Sheets.Add
objNewSheet.Name = "Auswertung"

'Bereich durchsuchen und bei Übereinstimmung Zeile kopieren und in Blatt "Auswertung" einfügen
With objAktSheet.Range("A1:IV65536")
    Set rngSuchbereich = .Find(What:=varSuchtext, LookIn:=xlValues)
    If Not rngSuchbereich Is Nothing Then
        strAddresse = rngSuchbereich.Address
        Do
            objAktSheet.Rows(rngSuchbereich.Row).Copy _
                objNewSheet.Cells(objNewSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 1)
            Set rngSuchbereich = .FindNext(rngSuchbereich)
        Loop While Not rngSuchbereich Is Nothing And rngSuchbereich.Address <> strAddresse
    End If
End With

Set objAktSheet = Nothing
Set objNewSheet = Nothing

End Sub
[/b]