10.03.2018, 23:47 (Dieser Beitrag wurde zuletzt bearbeitet: 10.03.2018, 23:49 von 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
helmut
Für mich ist die Möglichkeit in Excel an Zellen und Bereichen Namen zu vergeben die wichtigste Funktionalität. Sie macht Formeln und den VBA-code verständlicher. Für Makros gilt die Regel: "Nur über benannte Bereiche auf den Inhalt der Zellen zugreifen."
Und wofür sind Regeln da? Um nachzudenken bevor man sie bricht.
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!!!
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
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
helmut
Für mich ist die Möglichkeit in Excel an Zellen und Bereichen Namen zu vergeben die wichtigste Funktionalität. Sie macht Formeln und den VBA-code verständlicher. Für Makros gilt die Regel: "Nur über benannte Bereiche auf den Inhalt der Zellen zugreifen."
Und wofür sind Regeln da? Um nachzudenken bevor man sie bricht.
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