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