Übereinstimmungsvergleich - Fließtext

[tobipale]

Hi zusammen,

ich habe ein Excel Problem und weiß nicht, wie ich hier vorgehen soll, bzw. ob das überhaupt in Excel so möglich ist.

In der Beispieltabelle habe ich das Problem dargestellt.

Auf dem Tabellenblatt Übereinstimmung in der Tabelle 1 stehen mehrere IDs mit Suchbegriffen. 
Die Suchbegriffe der IDs sollen jeweils im Tabellenblatt Fließtext mit den Texten (einzeln) verglichen werden.
Dabei soll jeder Suchbegriff nur einmal gezählt werden (Problematik: Zeichen, Bindewörter wie ist). 
Anschließend soll im Tabellenblatt Übereinstimmung eine "Top 3" Liste der Übereinstimmung zwischen Suchbegriffe und Text ausgegeben werden. 
Das Buch mit der höchsten Übereinstimmung soll in der Tabelle mit "Buchtitel" dem "Text" und der ID Prio ausgegeben werden.
In Spalte H soll die Übereinstimmung stehen --> Übereinstimmung der Suchbegriffe/Wörter in Text
Top 2/3 soll wie in Spalte I ausgegeben werden.
Das ganze soll für jede ID separat erstellt werden.

-> Die erste Übereinstimmung ist nur ein Beispiel, wie es aussehen soll

Ich bin für jede Hilfe sehr dankbar!!!

Beste Grüße
tobipale

[Fennek]

Hallo,

im Automobilbau mag Süd-Deutschland ein wichtiges Land sein, im IT-Bereich ist es besser nur engl. Buchstaben zu nutzen.

Um die Häufigkeit der Suchworte auszuzählen hilft dieser Code:

Code:

Sub T_1()
Dim Ret(), Liste, Ar
Dim rng As Range, Adr As String

With Sheets("Fließtext")
  
    Liste = Sheets("Übereinstimmung").Range("C4:C12")
    
    For i = 1 To UBound(Liste)
        ReDim Ret(.Cells(Rows.Count, 3).End(xlUp).Row)
        Ar = Split(Liste(i, 1))
        For y = 0 To UBound(Ar)
            Set rng = .Columns(3).Find(Ar(y), , xlValues, xlPart)
            If Not rng Is Nothing Then
                Adr = rng.Address
                Do
                    Ret(rng.Row) = Ret(rng.Row) + 1
                    Set rng = .Columns(3).FindNext(rng)
                Loop Until rng.Address = Adr
            End If
            
        Next y
        Debug.Print Join(Ret, ";")
        Erase Ret
    Next i

End With
End Sub

Das Maximum zu finden wäre dann die nächste Aufgabe.

mfg

[schauan]

Hallöchen,

jetzt muss ich mich mal unwissend outen - was ist der Unterschied zwischen süddeutschen und englischen Buchstaben?
(mal abgesehen von deutschen Umlauten )

[snb]

Ich hab mal erst die leere Zeilen und Spalten gelöscht.

Code:

Sub M_snb()
  sn = Tabelle2.Cells(1).CurrentRegion
  sp = Tabelle1.Cells(1).CurrentRegion
 
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sn)
      .Item(sn(j, 1)) = Split(sn(j, 2))
    Next

    For j = 2 To UBound(sp) - 1
        st = Split(sp(j, 2))
        For jj = 1 To .Count - 1
          y = 0
          For jjj = 0 To UBound(st)
            y = y + (UBound(Filter(.Items()(jj), st(jjjj))) + 1)
          Next
          If y > 0 Then
              sp(j, 3) = y
              sp(j, 4) = .keys()(jj)
          End If
        Next
    Next
  End With

  Tabelle1.Cells(1).CurrentRegion.Offset(20) = sp
End Sub