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
|