Mehrere Wörter in Zelle suchen

[Fennek]

Hallo,

die Frage ist ein Problem: Der Code muss in einem allgemeinen Modul eingefügt werden, abeer das ist das absolute Basiswissen in VBA.

mfg

PS: ich kenne den Code von Gast 123 nicht

[respecter11]

Hey

Ja ich kenne mich nicht mit VBA aus das tut mir leid.
Sein Code lautet:

Code:

Option Explicit      '10.11.2016  Gast 123  Clever Forum


Dim Wort As String, dopp As String
Dim Txt1 As String, Txt2 As String


'Modul zum Namen vergleichen


Sub Namen_suchen()
Dim AC As Object, lz1 As Integer
Dim AJ As Object, lz2 As Integer
Dim Strg As String, Txt As String
Dim Tb2 As Worksheet, Zeile As Long
Set Tb2 = Worksheets("Tabelle2")

Sheets("Tabelle1").Select

With Sheets("Tabelle1")
   lz1 = .Cells(Rows.Count, 1).End(xlUp).Row
   lz2 = Tb2.Cells(Rows.Count, 1).End(xlUp).Row

   'alte Find Notizen löschen
   .Range("D2:F" & lz1) = Empty
   .Range("C2:C" & lz1) = "nicht da"
   Tb2.Range("C2:D" & lz2) = Empty

   '1. Schleife zum suchen ganzer Wörter
   For Each AC In Tb2.Range("A2:A" & lz2)
     dopp = Empty  'doppelte merken
     For Each AJ In .Range("A2:A" & lz1)
       If AJ.Value = "" Then _
          AJ.Offset(0, 2) = Empty  'Clr "nicht da"
       If AJ.Value = "" Then       'überspringen
       ElseIf AC.Value = AJ.Value Then
          If AJ.Value = dopp Then _
             AJ.Offset(0, 3) = "dopp " & Zeile
          AJ.Offset(0, 2) = AC.Row
          AC.Offset(0, 2) = "ok"
          dopp = AC.Value:  Zeile = AJ.Row
       End If
     Next AJ
     'Prüfung auf Leerzeichen im Namen
     If Len(Trim(AC)) <> Len(AC) Then _
        AC.Offset(0, 2) = "Space am Ende"
   Next AC

   '2.Schleife zum umgekehrte Namen suchen
   For Each AC In Tb2.Range("A2:A" & lz2)
       Txt1 = Empty: Txt2 = Empty
       Txt1 = Trim(Left(AC, InStr(AC, " ")))
       Txt2 = Trim(Right(AC, Len(AC) - InStr(AC, " ")))
       Wort = Txt2 & " " & Txt1:  dopp = Empty
     'Anf-Ende vertauscht, Len gleich
     If Len(Wort) = Len(AC) Then
     For Each AJ In .Range("A2:A" & lz1)
       If AJ.Value = AC.Value Then _
          dopp = Wort: Zeile = AJ.Row
       If AJ.Offset(0, 2) <> "nicht da" Then
       ElseIf AJ.Value = Wort Then
          AJ.Offset(0, 4) = AC.Value
          AJ.Offset(0, 2) = AC.Row
          If dopp = Wort Then _
             AJ.Offset(0, 3) = "dopp " & Zeile
       End If
     Next AJ
     End If
   Next AC

   '3.Schleife für restliche Teil-Namen suchen
   'wertet Anf-End Namen aus, ohne Mittelteil!!
   For Each AJ In .Range("A2:A" & lz1)
     If AJ.Offset(0, 2) = "nicht da" Then
       Txt1 = Trim(Left(AJ, InStr(AJ, " ")))
       Txt2 = Trim(Right(AJ, InStrRev(AJ, " ")))
     'Anf-Ende vertauscht, Len gleich
     For Each AC In Tb2.Range("A2:A" & lz2)
       If InStr(AC, Txt1) Or InStr(AC, Txt2) Then
          AJ.Offset(0, 3).Font.ColorIndex = 3
          AJ.Offset(0, 3) = "prüfen !!"
          AJ.Offset(0, 4) = AC.Value
          AJ.Offset(0, 2) = AC.Row
       End If
     Next AC
     End If
   Next AJ
End With
End Sub

Ich habe sein Code herausgelöscht und deinen Eingefügt, jedoch steht dann folgendes, wenn ich es ausführen möchte. (siehe Anhang)


Grüsse
/Respecter11

[Fennek]

Hallo,

etwas allgemeiner gesagt: Die Fragestellung fand ich interessant und wäre bereit, etwas mehr Zeit als üblich dafür einzusetzen (noch etws lernen). Aber es erfordert, dass der Fragesteller zumindest Grundkenntnisse in VBA hat, ansonsten "hängt" es an allen Stellen.

Mal schaun wie das weitergeht.

mfg

[respecter11]

Hey

Ja verstehe ich natürlich auch dass das etwas mühsam ist. Jedoch wäre ich froh, wenn ich diese 2000 falsche Namen nicht alle von Hand via "Suchen" suchen und eintragen muss. Ich wäre dir oder euch sehr dankbar für eine solche VBA Formel.

Grüsse
/Respecter11