Hallo, hier noch etwas fuer Dich :-)
Am Anfang muss man den Bereich auswaehlen, wo man suchen wird und in den InputBox muss man dann die gesuchte Kette eingeben. Gruss dd
Option Explicit
Public
Sub ZeilenKopieren_MitKriteria()
Dim DurchgesuchterBereich
Dim Zelle
Dim vntKriteria
Dim TabelleKopiertenZeilen
Dim Gefunden
Dim Zeile
Dim SheetNummer
Dim NeuerTabellenName
Const SHNAME As String = "Ergebnis"
On Error GoTo Err_In_ZeilenKopieren_MitKriteria
If (VBA.TypeName(Application.Selection) <> "Range") Then MsgBox "Zellen auswaehlen!", vbExclamation: End
Set DurchgesuchterBereich = Application.Selection
vntKriteria = Application.InputBox("Kriteria eingeben (z.B. ""closed"")", "Kriteria")
If (VBA.VarType(vntKriteria) <> vbString) Then End
If (VBA.CStr(vntKriteria) = "") Then MsgBox "Empty String, End.", vbInformation: End
Set TabelleKopiertenZeilen = ThisWorkbook.Worksheets.Add
NeuerTabellenName = SHNAME
TabelleKopiertenZeilen.Name = NeuerTabellenName
Gefunden = False
Zeile = 0
SheetNummer = 0
For Each Zelle In DurchgesuchterBereich.Cells
If (VBA.CStr(Zelle.Value) = VBA.CStr(vntKriteria)) Then
Gefunden = True
Zeile = Zeile + 1
Zelle.EntireRow.Copy TabelleKopiertenZeilen.Cells(Zeile, 1)
End If
Next Zelle
If (Gefunden = False) Then
Application.DisplayAlerts = False
TabelleKopiertenZeilen.Delete
Application.DisplayAlerts = True
End If
Exit Sub
Err_In_ZeilenKopieren_MitKriteria:
If (Err.Number = 1004) Then
Dim sh
SheetNummer = SheetNummer + 1
For Each sh In ThisWorkbook.Worksheets
If (sh.Name = NeuerTabellenName) Then
NeuerTabellenName = SHNAME & "_" & VBA.CStr(SheetNummer)
Resume
End If
Next sh
Else
MsgBox "Error : " & Err.Number, vbCritical
End If
End Sub