Clever-Excel-Forum

Seiten: 1 2

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

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!!!

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.

Zitat: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

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

Seiten: 1 2

Ego

Nicki

Ego

Wastl