|
Hallo
in ein Modul
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 ' 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
Neu = 1 'ZielZeile
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
End With
End Sub
LG UweD
|