Sub Teilstring_auslesen()
'** Suchstring festlegen
strSuchstring = ActiveSheet.Range("G2").Value
For a = 1 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
pos1 = InStr(1, ActiveSheet.Cells(a, 1).Value, strSuchstring, 1)
If pos1 > 0 Then
ActiveSheet.Cells(a, 2).Value = strSuchstring
End If
Next a
End Sub