Clever-Excel-Forum

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

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

Hallöchen,

jetzt muss ich mich mal unwissend outen - was ist der Unterschied zwischen süddeutschen und englischen Buchstaben?

(mal abgesehen von deutschen Umlauten 100

)

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

tobipale

Fennek

schauan

snb