Sub FindString()
 
Dim wb As Workbook
Set wb = ActiveWorkbook
 
Dim ws As Worksheet
Set ws = wb.Sheets("Tabelle1")
 
Dim rg As Range
Set rg = ws.Range("D:D")
 
Dim Suchwert As String
Suchwert = "\fs"
 
Dim GefZelle As Object
Set GefZelle = rg.Find(What:=Suchwert)
 
Dim firstAddress As String
Dim strZellinhalt As String
 
With rg
    Set GefZelle = .Find(Suchwert)
    If Not GefZelle Is Nothing Then
    firstAddress = GefZelle.Address
        Do
                zellinhalt = Cells(GefZelle.Row, GefZelle.Column).Value
        Dim strErgebnis As String
        strErgebnis = BereinigeString(zellinhalt, Suchwert)
        Cells(GefZelle.Row, 5).Value = strErgebnis
            Set GefZelle = .FindNext(GefZelle)
            If GefZelle Is Nothing Then
                GoTo DoneFinding
            End If
            Loop While Not GefZelle Is Nothing And GefZelle.Address <> _
              firstAddress
    End If
DoneFinding:
MsgBox ("Die Suche ist beendet!")
End With
 
End Sub
 
Function BereinigeString(ByVal strText As String, ByVal Suchwert As String) As _
  String
 
Dim i As Integer
i = InStr(strText, Suchwert)
 
Dim retVal As String
retVal = Right(strText, Len(strText) - 93)
 
Dim j As Integer
j = InStr(retVal, "\par")
 
retVal = Left(retVal, j - 1)
 
BereinigeString = Trim(retVal)
 
End Function

EALA FREYA FRESENA