Sub
Transferieren()
Dim
Tb1
As
Worksheet, Tb2
As
Worksheet, LR
As
Integer
, i
As
Integer
Dim
SP0
As
Integer
, SP1
As
Integer
, SP2
As
Integer
, Z1
As
Integer
Dim
Such1
As
String
, Such2
As
String
, Neu
As
Integer
Set
Tb1 = Sheets(
"Tabelle1"
)
Set
Tb2 = Sheets(
"Tabelle2"
)
Z1 = 2
SP0 = 1
SP1 = 1
SP2 = 2
Such1 =
"FS"
Such2 =
"VT"
Tb2.UsedRange.ClearContents
With
Tb1
LR = .Cells(.Rows.Count, SP0).
End
(xlUp).Row
Neu = 1
For
i = Z1
To
LR
If
InStr(.Cells(i, SP0), Such1) > 0
Then
.Cells(i, SP0).Copy Tb2.Cells(Neu, SP1)
Neu = Neu + 1
ElseIf
InStr(.Cells(i, SP0), Such2) > 0
Then
.Cells(i, SP0).Copy Tb2.Cells(Neu, SP2)
Neu = Neu + 1
End
If
Next
End
With
End
Sub