Hallo zusammen,
ich habe folgendes Makro, bei welchem ich einen einzelnen Buchstaben eingebe, woraufhin mir sämtliche Wörter, die diesen Buchstaben enthalten, in die Tabelle 2 kopiert werden. Nun möchte ich nicht nur nach einzelnen Buchstaben, sondern auch nach Buchstabenfolgen (die ev. auch ganzen Wörtern entsprechen) suchen, in der Tabelle 2 soll dann aber wiederum das ganze Wort angegeben. Kann mir jemand helfen, das Makro entsprechend abzuändern? Vielen Dank!
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
