|
Mit folgendem Code kommst du ein wenig weiter. Du musst dir nur noch überlegen, wie du das Ergebnis so gestalten kannst, dass eine Zeile ggf. nur einmal auf Tabelle3 kopiert wird, auch wenn beide Suchbegriffe in einer Zeile vorkommen. Da wird dir schon etwas einfallen ;-)
Option Explicit
Sub Main()
Dim strSuch1 As String, strSuch2 As String
strSuch1 = Worksheets("Tabelle2").Cells(5, 3).Value
strSuch2 = Worksheets("Tabelle2").Cells(10, 3).Value
Suche_Und_Kopiere (strSuch1)
Suche_Und_Kopiere (strSuch2)
End Sub
Sub Suche_Und_Kopiere(strSuche As String)
Dim rngC As Range, lngZeile As Long, strAdresse As String
Worksheets("Tabelle1").Activate
Application.ScreenUpdating = False
With Worksheets("Tabelle1").Columns("A:D")
Set rngC = .Find(strSuche)
If Not rngC Is Nothing Then
strAdresse = rngC.Address
Do
lngZeile = rngC.Row
Range(Cells(lngZeile, 1), Cells(lngZeile, 4)).Copy
With Worksheets("Tabelle3")
.Cells(.Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
Set rngC = .FindNext(rngC)
Loop While Not rngC.Address = strAdresse
End If
End With
Application.CutCopyMode = False
Worksheets("Tabelle3").Activate
End Sub
|