Option Explicit
Sub SuchenUndKopieren()
Dim strEingabe As String
Dim Bereich As Range
Dim Zelle As Range
Dim lngletzte As Long
With Worksheets("Tabelle1") 'Tabellennamen _
eventeull anpassen
Set Bereich = .Range(.Cells(2, 11), .Cells(Rows.Count, 11).End(xlUp)) 'Die 11 steht für _
Spalte K
End With
strEingabe = InputBox("Bitte Suchbegriff eingeben", "Suchen")
For Each Zelle In Bereich
If Zelle.Value = strEingabe Then
lngletzte = Worksheets("Tabelle2").Cells(Rows.Count, 11).End(xlUp).Row
Zelle.EntireRow.Copy Destination:=Worksheets("Tabelle2").Cells(lngletzte, 1).Offset(1, _
0) 'Tabellennamen eventuell anpassen
End If
Next
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Mustafa()
Dim rng As Range, rngSearch As Range, rngFound As Range
Dim objWB As Workbook
Dim strFirst As String, strSearch As String
Dim lngRows() As Long, lngIndex As Long
strSearch = InputBox("Bitte Suchbegriff eingeben:", "Suchen")
Redim lngRows(0)
If strSearch <> "" Then
With ActiveSheet
If Selection.Rows.Count = .Rows.Count Then
Set rng = Selection
Else
Set rng = .UsedRange
End If
End With
Set rngSearch = rng.Find(What:=strSearch, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not rngSearch Is Nothing Then
strFirst = rngSearch.Address
Do
If IsError(Application.Match(rngSearch.Row, lngRows, 0)) Then
Redim Preserve lngRows(lngIndex)
lngRows(lngIndex) = rngSearch.Row
lngIndex = lngIndex + 1
If rngFound Is Nothing Then
Set rngFound = rngSearch.EntireRow
Else
Set rngFound = Union(rngFound, rngSearch.EntireRow)
End If
End If
Set rngSearch = rng.FindNext(rngSearch)
Loop While Not rngSearch Is Nothing And strFirst <> rngSearch.Address
End If
If Not rngFound Is Nothing Then
Set objWB = Workbooks.Add(xlWBATWorksheet)
rngFound.Copy objWB.Sheets(1).Cells(1, 1)
objWB.Activate
End If
End If
Set rng = Nothing
Set rngSearch = Nothing
Set rngFound = Nothing
Set objWB = Nothing
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Mustafa()
Dim rng As Range, rngSearch As Range, rngFound As Range
Dim objWB As Workbook
Dim strFirst As String, strSearch As String
Dim lngRows() As Long, lngIndex As Long
Dim strWorkBook As String
strWorkBook = "Pfad und Name deiner Bestimmten.xls" 'Anpassen!
strSearch = InputBox("Bitte Suchbegriff eingeben:", "Suchen")
Redim lngRows(0)
If strSearch <> "" Then
With ActiveSheet
If Selection.Rows.Count = .Rows.Count Then
Set rng = Selection
Else
Set rng = .UsedRange
End If
End With
Set rngSearch = rng.Find(What:=strSearch, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not rngSearch Is Nothing Then
strFirst = rngSearch.Address
Do
If IsError(Application.Match(rngSearch.Row, lngRows, 0)) Then
Redim Preserve lngRows(lngIndex)
lngRows(lngIndex) = rngSearch.Row
lngIndex = lngIndex + 1
If rngFound Is Nothing Then
Set rngFound = rngSearch.EntireRow
Else
Set rngFound = Union(rngFound, rngSearch.EntireRow)
End If
End If
Set rngSearch = rng.FindNext(rngSearch)
Loop While Not rngSearch Is Nothing And strFirst <> rngSearch.Address
End If
If Not rngFound Is Nothing Then
Set objWB = Workbooks.Open(strWorkBook)
With objWB.Sheets(1) 'evtl. Tabellenname angeben! Z.B.: .Sheets("Tabelle1")
.Cells(2, 1).Resize(.UsedRange.Rows.Count - 1, .UsedRange.Columns.Count).Clear
rngFound.Copy .Cells(2, 1)
End With
objWB.Activate
Else
MsgBox "Nix gefunden!"
End If
End If
Set rng = Nothing
Set rngSearch = Nothing
Set rngFound = Nothing
Set objWB = Nothing
End Sub