Hallo Stephan,

von wegen "zeilenbezogen in die Tabelle2 untereinander"

Quick&Dirty 2 Varianten

Option Explicit

Sub KopiereSuchBegriffGleicheZeilen()
Dim t As Range, v As Range
Dim a As Range, b As Range, d As Range
Dim zWs As Worksheet
'
On Error GoTo errorhandler
Set zWs = Sheets("Tabelle2")
zWs.Cells.Clear
With Sheets("Tabelle1").[I:I]
  Set t = .Find("Test", LookIn:=xlValues)
  If Not t Is Nothing Then
    Set v = t
      Do
        Set a = t.Offset(0, -8)
        a.Copy Destination:=zWs.Range(a.Address)
        Set b = t.Offset(0, -7)
        b.Copy Destination:=zWs.Range(b.Address)
        Set d = t.Offset(0, -5)
        d.Copy Destination:=zWs.Range(d.Address)
        '
        Set t = .FindNext(t)
      Loop While Not t Is Nothing And t.Address <> v.Address
  End If
End With
'
Exit Sub
errorhandler:
MsgBox "Fehler in der Tabellenstruktur"
End Sub

Sub KopiereSuchBegriffUntereinander()
Dim t As Range, v As Range, z As Range
Dim a As Range, b As Range, d As Range
Dim zWs As Worksheet
'
On Error GoTo errorhandler
Set zWs = Sheets("Tabelle2")
Set z = zWs.[A1]
zWs.Cells.Clear
With Sheets("Tabelle1").[I:I]
  Set t = .Find("Test", LookIn:=xlValues)
  If Not t Is Nothing Then
    Set v = t
      Do
        Set a = t.Offset(0, -8)
        a.Copy Destination:=zWs.Range(z.Address)
        Set b = t.Offset(0, -7)
        b.Copy Destination:=zWs.Range(z.Offset(0, 1).Address)
        Set d = t.Offset(0, -5)
        d.Copy Destination:=zWs.Range(z.Offset(0, 3).Address)
        '
        Set t = .FindNext(t)
        Set z = z.Offset(1, 0)
      Loop While Not t Is Nothing And t.Address <> v.Address
  End If
End With
'
Exit Sub
errorhandler:
MsgBox "Fehler in der Tabellenstruktur"
End Sub