Vergleich von Wörtern mit Prozenten

[Ego]

Hallo N...,

nein, er zeigt alle Zellen an, bei denen x% der Wörter des aktuellen Satzes in dieser speziellen Reihenfolge übereinstimmen?


ps. Ich hatte noch einen  kleinen Fehler falls alle Worte eines kürzeren Satzes mit den ersten Worten eines längeren Satzes übereinstimmen. Dann müssen hinter der Zeile mit "lngWort = lngWort + 1" noch folgende 3 Zeilen geschrieben werden:

Code:

            If lngWort = lngAnzSatz Then
                lngAnzGleich = lngWort
            End If

[Nicki]

Ja es ist (fast) Perfekt!
könntest du vielleicht noch eine Kleinigkeit korrigieren?
Wenn in zwei Zellen genau das gleiche steht verweisen sie nicht aufeinander.
Das machen sie erst wenn es eine minimale Abweichung gibt.
Vielen Dank für das alles!!!

[Ego]

Hallo N...,

Ich habe bisher nicht mit gleichen Sätzen gerechnet.  Da ich nicht überprüft hatte, ob die Zelle des aktuellen Satzes im Bereich der zu prüfenden Sätze liegt, hätte ich bei Zulassung von gleichen Sätzen auch immer den selben Satz mit ausgewiesen.

In der Anlage habe ich den ersten Parameter auf zwei Zellen erweitert. Neben dem aktuellen Satz wird also auch die aktuelle Kennung übergeben.

Option Explicit

Public Function Anteil(rngSatz As Range, rngListe As Range, dblAnteil As Double) As String
Dim lngWort As Long
Dim lngZeile As Long
Dim lngAnzSatz As Long
Dim lngAnzAkt As Long
Dim lngAnzGleich As Long
Dim dblAkt As Double
Dim varListe As Variant
Dim varSatz As Variant
Dim strWorteSatz() As String
Dim strWorteAkt() As String
Dim strAkt As String
Dim strSatz As String
Dim blnWeiter As Boolean

Anteil = ""
varListe = rngListe.Value
varSatz = rngSatz.Value
strSatz = varSatz(1, 2)

strWorteSatz = Split(strSatz, " ")
lngAnzSatz = UBound(strWorteSatz) + 1

For lngZeile = 1 To UBound(varListe, 1)
    strAkt = varListe(lngZeile, 2)
    If strAkt <> strSatz And strAkt <> "" Or varListe(lngZeile, 1) <> varSatz(1, 1) Then
        strWorteAkt = Split(strAkt, " ")
        lngAnzAkt = UBound(strWorteAkt) + 1
        If lngAnzAkt > lngAnzSatz Then
            lngAnzAkt = lngAnzSatz
        End If
        lngAnzGleich = 0
        lngWort = 0
        blnWeiter = True
        Do While lngWort < lngAnzAkt And blnWeiter
            If strWorteSatz(lngWort) <> strWorteAkt(lngWort) Then
                blnWeiter = False
                lngAnzGleich = lngWort
            End If
            lngWort = lngWort + 1
            If lngWort = lngAnzSatz Then
                lngAnzGleich = lngWort
            End If
        Loop
        dblAkt = lngAnzGleich / lngAnzSatz
        If dblAkt >= dblAnteil Then
            Anteil = Anteil & ", " & varListe(lngZeile, 1)
        End If
    End If
Next lngZeile

If Len(Anteil) > 2 Then
    Anteil = Right(Anteil, Len(Anteil) - 2)
End If

End Function

[Wastl]

Moin,

so ein Problem hatte ich schon mal und habe das mit der Funktion gelöst bekommen

Code:

Function ähnlich(T1 As String, t2 As String) As Long
'ermittelt die Länge der längsten Zeichenfolge, die in beiden Texten überein stimmt

Dim l As Long
Dim x As Long
Dim y As Long
Dim maxFolge As Long
Dim Folge As Long

l = Len(T1)

For x = 1 To l
For y = 1 To l
If l >= x + y - 1 Then
Folge = IIf(InStr(1, t2, Mid(T1, x, y)), y, 0)
If Folge > maxFolge Then
maxFolge = Folge
End If

End If
Next
Next

ähnlich = maxFolge

End Function

Aufgerufen wurde das mit dem teil:

Code:

Private Sub Voorsicht()
Dim T1 As String, t2 As String, i As Long, Ende As Long
Ende = Cells(Rows.Count, 1).End(xlUp).Row 'hier Spalte 1, also A
   Range("H2").FormulaR1C1 = _
       "=IF(AND(R[2]C[-6]="""")*(RC[-5]<>R[1]C[-5])*(RC[-7]<>"""")*(R[1]C[-7]<>""""),""Vorsicht"","""")"
   Range("H2:H" & Ende).FillDown
   Calculate
   Range("H2:H" & Ende).Copy
   Range("H2").PasteSpecial Paste:=xlValues
   Application.CutCopyMode = False
   Selection.TextToColumns Destination:=Range("H2"), DataType:=xlDelimited, _
       TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
       Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
       :=Array(1, 1)
'            Stop
       Application.Calculation = xlCalculationManual
           For i = 2 To Ende
   If Cells(i, 6) = "" Then
   On Error Resume Next
       If Cells(i, 8) = "Vorsicht" Then
           Cells(i, 7).FormulaR1C1 = "=LEN(RC[-4])"
           Cells(i + 1, 7).FormulaR1C1 = "=LEN(RC[-4])"
'
'            Cells(i, 6).FormulaArray = "=MAX(IF(ISNUMBER(FIND(MID(RC[-3],ROW(INDIRECT(""1:""&LEN(RC[-3]))),COLUMN(R[-1])),R[1]C[-3])),LEN(MID(RC[-3],ROW(INDIRECT(""1:""&LEN(RC[-3]))),COLUMN(R[-1])))))"
           T1 = Cells(i, 3)
           t2 = Cells(i + 1, 3)
           Ergebnis = ähnlich(T1, t2)
           Cells(i + 1, 8) = Ergebnis
       End If
   Else
       Cells(i, 7).FormulaR1C1 = "=LEN(RC[-4])"
   End If
   Next i
   Application.Calculation = xlCalculationAutomatic
   [b2].Select
End Sub

passend auf meine damalige Anforderung