|
Hallo Tho,
dann versuchs mal so, dass alle benutzten Spalten durchgegangen werden als zusaetzliche Schleife:
Sub Transferieren()
Dim Tb1 As Worksheet, Tb2 As Worksheet, LR As Integer, LS 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 ' Erste Datenzeile (wegen Überschrift)
SP0 = 1 'suchen in Spalte A
SP1 = 1 'ablegen 1 in Spalte A
SP2 = 2 'ablegen 1 in Spalte B
Such1 = "FS"
Such2 = "VT"
'reset
Tb2.UsedRange.ClearContents
With Tb1
LR = .Cells(.Rows.Count, SP0).End(xlUp).Row 'letzte Zeile der Spalte
LS = .Cells(1, .Columns.Count).End(xlToLeft).Column 'letzte benutzte Spalte in Zeile 1
Neu = 1 'ZielZeile
For SP0 = 1 To LS
For i = Z1 To LR
If InStr(.Cells(i, SP0), Such1) > 0 Then 'suchen erstes Wort
.Cells(i, SP0).Copy Tb2.Cells(Neu, SP1) 'in Spalte A
Neu = Neu + 1
ElseIf InStr(.Cells(i, SP0), Such2) > 0 Then 'suchen zweites Wort
.Cells(i, SP0).Copy Tb2.Cells(Neu, SP2) 'in Spalte B
Neu = Neu + 1
End If
Next
Next
End With
End Sub
Gruss Torsten
|