Alternativen zu Soundex-Verfahren

Hallo,
ich habe eine Tabelle in der ich die Werte einer Spalte mittels Soundex auf Ähnlichkeit mit einem einzugebenden Wert in E2 abgleiche (enthaltene Werte und eingegebene Suchbegriffe sind immer in Englisch und E2 befindet sich auf dem gleichen Blatt wie die Daten).
Grundsätzlich klappt das ganz gut, allerdings liefert Soundex sehr schlechte bzw. ungenaue Ergebnisse, wenn der eingegebene Suchbegriff etwas länger ist oder Text am Anfang enthält, der nicht in der Spalte für den Abgleich enthalten ist (z.B. findet die Suche so für "Tom Meier" nichts, wenn in der Tabelle nur "Meier" eingetragen ist).
Kennt jemand einen Code, der hier feinere Ergebnisse (bei englischer Sprache) liefert oder mehr Möglichkeiten zur Anpassung bietet ? Vielleicht hat jemand auch schon mal mit Metaphone oder Levenshtein gearbeitet, dazu habe ich bisher noch keine VBA-Beispiele gefunden.
Freue mich über jeden Tipp !
Viele Grüße und vielen Dank im Voraus,
Frank

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Sepp,
ich habe nach einigem Suchen folgenden Code gefunden - mir ist hier allerdings nicht klar, wie ich diesen konkret in meiner Tabelle anwende, wenn der Suchbegriff in E2 steht und dieDaten für den Abgleich in Spalte W.
Kann mir hier jemand weiterhelfen ?
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Function mp(s1 As String, s2 As String) As Double
Dim t As String
Dim i As Long, n As Long
'ensure s1 is shorter string - remove if undesired
If Len(s1) > Len(s2) Then
t = s1
s1 = s2
s2 = t
End If
n = Len(s1)
i = 1
t = s1
'eliminate chars from s1 that aren't in s2
Do While i If InStr(s2, Mid(t, i, 1)) > 0 Then
i = i + 1
Else
t = Left(t, i - 1) & Mid(t, i + 1)
n = n - 1
End If
Loop
mp = mpr(t, s2) / CDbl(Len(s1))
End Function
'call this only from mp() and recursively to give the
'number of chars in s1 matching chars in order in s2
'

Private Function mpr(ByVal s1 As String, s2 As String) As Long
Dim i As Long, n1 As Long, p As Long, q As Long, m As Long
n1 = Len(s1)
q = 1
'find each char from s1 in substrings of s2 to
'the right of the previously matched char in s2
For i = 1 To n1
p = InStr(q, s2, Mid(s1, i, 1))
If p > 0 Then q = p + 1 Else Exit For
Next i
If i > n1 Then
'if the For-loop above completed, i = n1 + 1 AND all
'chars in s1 were found in s2 in order, so all done
mpr = n1
Else
'no joy, time for recursion with substrings of s1
For i = 1 To n1
m = mpr(Left(s1, i - 1) & Mid(s1, i + 1), s2)
If m > mpr Then mpr = m 'store longest match found
If mpr = n1 - 1 Then Exit For 'if longest substring matches, all done
Next i
End If
End Function

Viele Grüße ,
Frank

Beliebteste Forumthreads (12 Monate)

Alternativen zu Soundex-Verfahren

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Alternativen zu Soundex-Verfahren

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread