hallo kollegen

habt ihr keine Zähne im Mund, oder was hindert euch am Code "vorkauen". Sorry,ihr seit beide schlicht und einfach nur besserwisserische Schwätzer! Keine echten Helfer!

Hier mal ein Code, den du noch selbst anpassen musst. Deine Angaben waren zu unvollständig um ihn dirket korrekt schreiben zu können. Keine Tabellenname für Worksheet A+B und keine genauen Angaben zu den Spalten wo gesucht werden muss. Setze bitte deine Tabellen Namen und deine Spalten im Code ein, dann sollte er klappen. Vergiss nicht bei Set rFind auch in der [y1] Klammer die richtige Spalte anzugeben.

Das Ergebniswird dir in WorksheetsA in der Spalte neben dem Suchtext angezeigt. Sowohl wie oft ein Wort vorkommt, und das gefundene Wort.

mfg Nobody

Sub Worksheets_vergleichen()
Dim AC As Range, Txt As String, j As Integer
Dim rFind As Range, Adr1 As String, lz1 As Long
Dim TbX As Worksheet, n As Integer, Arry 'Array
Set TbX = Worksheets("Tabelle2")  '** WorkshhetB Namen einsetzen

With Worksheets("Tabelle1")       '** WorkshhetA Namen einsetzen
     '** gewünschte Spalte "X" angeben
     lz1 = .Cells(Rows.Count, "X").End(xlUp).Row
     .Range("X2:X" & lz1).Offset(0, 1).ClearContents
     
     'Schleife für alle Zeilen in WorksheetsA durchsuchen
     For Each AC In .Range("X2:X" & lz1)   '** X Bereich WorksheetA angeben
         '**Split mit Space, sonst Trennzeichen angeben
         Arry = Split(Trim(AC), " ")
         If UBound(Arry) = 0 Then Arry(0) = Trim(AC)
         If AC.Value <> Empty Then
         'Schleife für alle Wörter im Text durchsuchen
         For j = LBound(Arry) To UBound(Arry)
             'Suchlauf in Spalte "Y" WorksheetB nach Einzelwort
             Set rFind = TbX.Columns("Y").Find(What:=Trim(Arry(j)), After:=[y1], LookIn:=xlFormulas, _
                 LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
             'Wort gefunden, weitersuchen
             If Not rFind Is Nothing Then
                Adr1 = rFind.Address: n = 0
                Txt = AC.Offset(0, 1).Value
                If Txt <> "" Then Txt = Txt & ", "
                Do  'Do loop um alle Wörter zu finden
                    n = n + 1
                    AC.Offset(0, 1) = Txt & n & "x " & Trim(Arry(j))
                    Set rFind = TbX.Columns("Y").FindNext(rFind)
                Loop Until rFind.Address = Adr1
            End If
         Next j
         End If
     Next AC
End With
End Sub