Option Explicit

Sub suchen_kopieren()

Application.ScreenUpdating = False
Dim Begriff As String, gefunden As Variant, firstAddress As Variant, _
Zeile As Long

Dim strSuchwort() As String
Dim iSuchwort As Integer
Dim iWortlänge As Integer

Begriff = InputBox("suche nach:", "Suchbegriff")
If Begriff = "" Then Exit Sub
With Sheets("Tabelle1").Cells
    Set gefunden = .Find(Begriff, LookIn:=xlValues)
    If Not gefunden Is Nothing Then
        firstAddress = gefunden.Address
        Do
            'Text aus der gefundenen Zelle in einzelne Wörter aufsplitten
            strSuchwort = Split(Range(gefunden.Address), " ")
            'Alle Wörter der gefundenen Zelle durchsuchen
            For iSuchwort = 0 To UBound(strSuchwort)
                'Abgefragtes Wort Buchstabenweise durchsuchen
                For iWortlänge = 1 To Len(strSuchwort(iSuchwort))
                    'Wenn abgefragter Buchstabe mit dem Suchbegriff übereinstimmt, Wort kopieren
                    If Mid(strSuchwort(iSuchwort), iWortlänge, 1) = Begriff Then
                        Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = _
                            strSuchwort(iSuchwort)
                    End If
                Next
            Next
            Set gefunden = .FindNext(gefunden)
        Loop While Not gefunden Is Nothing And gefunden.Address <> firstAddress
    End If
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub