Herbers Excel/VBA-Archiv

Index mit ungefährer Übereinstimmung

• Index mit ungefährer Übereinstimmung von Dominic vom 23.09.2014 10:36:31
• AW: Index mit ungefährer Übereinstimmung - von Klaus M.vdT. am 23.09.2014 11:11:53
  • AW: Index mit ungefährer Übereinstimmung - von Dominic am 23.09.2014 11:20:50
    • Soundex-VBA Script - von Klaus M.vdT. am 23.09.2014 11:45:45
    • Levenshtein VBA-Script - von Klaus M.vdT. am 23.09.2014 11:48:56

Betrifft: Index mit ungefährer Übereinstimmung von: Dominic
Geschrieben am: 23.09.2014 10:36:31

Hi zusammen,

ich stehe gerade auf dem Schlauch.
Ich nutze folgende Funktion um aus dem Blatt Datenbasis eine Referenz/ Kundennummer heraussuchen.

INDEX(Datenbasis!A:A;VERGLEICH(Datensammlungen!X3;Datenbasis!B:B;0))

Nun ist es jedoch so, dass im Blatt Datensammlungen X3 ein Kundenname steht.
Im Blatt Datenbasis sieht es wie folgt aus:

Spalte A: Referenz/ Kundennummern
Spalte B: Kundennamen

Hinweis: Jeder Kunde kann in diesem Tabellenblatt mehrere hundert male aufgeführt werden (für jede Transaktion eine Zeile). Durch ein VBA Skript lasse ich mir bereits jeden Kunden der in diesem Blatt aufgeführt wird, EINMALIG in Spalte X im Blatt Datensammlungen ausgeben. Wichtig ist eben nun, das ich zu jedem Kunden dessen einmalige ID/Referenz eben auch benötige. Bisher habe ich das eben über o. g. Index Funktion versucht.

Zusätzliche Herausforderung: Es kann hier durchaus minimale Abweichungen in den Kundennamen geben. Das mal ein Leerzeichen mehr oder weniger zwischen Kundenname und Firmierung existiert. Wie kann ich die o. g. Index Funktion

Betrifft: AW: Index mit ungefährer Übereinstimmung von: Klaus M.vdT.
Geschrieben am: 23.09.2014 11:11:53

Hallo Dominic,
was für den Menschen eine minimale Abweichung ist, stell für den Computer eine Welt an Unterschied dar. Auch die unscharfen Verweise mit Bereich_Verweis = WAHR werden dir hier nicht helfen.

Um STRINGS unscharf auf Ähnlichkeiten zu prüfen, gibt es mehrere Ansätze. Mit dem SOUNDEX Ansatz werden Strings auf phonetische Ähnlichkeit geprüft. Das eignet sich insbesondere bei Namen, da im SOUNDEX die Firma "Meier Transporte" identisch mit der Firma "Meyer Transporte" wird.
Ein anderer Ansatz ist die LEVENSHTEIN-Distanz, welche angibt wie viele Änderungsschritte zwischen zwei Strings liegen.

Für beides hätte ich fertige VBA-Scripte hier rumliegen. Kannst du dir eine solche Lösung vorstellen?

Grüße,
Klaus M.vdT.

Betrifft: AW: Index mit ungefährer Übereinstimmung von: Dominic
Geschrieben am: 23.09.2014 11:20:50

Hi Klaus,
dessen war ich mir bewusst und habe aus diesem Grunde hier nachgefragt da ich keine Idee hatte diese kleinen Abweichungen mit zu berücksichtigen.

Die Soundex Methode klingt gut. Würde mich zu dem VBA Skript freuen! :)

Betrifft: Soundex-VBA Script von: Klaus M.vdT.
Geschrieben am: 23.09.2014 11:45:45

Hi,

In A1 Steht "Batterie", in A2 ergibt die Formel
=SOUNDEX(A1;4)
den Wert B360

Damit kannst du dann Vergleiche in Hilfsspalten anstellen. Über die Vor-Nachteile des SOUNDEX Verfahrens googelst und wikipediast du dich bitte selber schlau.

Option Explicit

Function Soundex(Surname As String, iLen As Integer) As String
' Developed by Richard J. Yanco
' This function follows the Soundex rules given at
' http://home.utah-inter.net/ _
kinsearch/Soundex.html


Dim Result As String, c As String * 1
Dim Location As Integer

Surname = UCase(Surname)

' First character must be a letter
If Asc(Left(Surname, 1)) < 65 Or Asc(Left(Surname, 1)) > 90 Then
Soundex = ""
Exit Function
Else
' St. is converted to Saint
If Left(Surname, 3) = "ST." Then
Surname = "SAINT" & Mid(Surname, 4)
End If

' Convert to Soundex: letters to their appropriate digit,
' A,E,I,O,U,Y ("slash letters") to slashes
' H,W, and everything else to zero-length string

Result = Left(Surname, 1)
For Location = 2 To Len(Surname)
Result = Result & Category(Mid(Surname, Location, 1))
Next Location

' Remove double letters
Location = 2
Do While Location < Len(Result)
If Mid(Result, Location, 1) = Mid(Result, Location + 1, 1) Then
Result = Left(Result, Location) & Mid(Result, Location + 2)
Else
Location = Location + 1
End If
Loop

' If category of 1st letter equals 2nd character, remove 2nd character
If Category(Left(Result, 1)) = Mid(Result, 2, 1) Then
Result = Left(Result, 1) & Mid(Result, 3)
End If

' Remove slashes
For Location = 2 To Len(Result)
If Mid(Result, Location, 1) = "/" Then
Result = Left(Result, Location - 1) & Mid(Result, Location + 1)
End If
Next

' Trim or pad with zeroes as necessary
'Dim iLen As Integer
'iLen = 12

Select Case Len(Result)
Case iLen
Soundex = Result
Case Is < iLen
Soundex = Result & String(iLen - Len(Result), "0")
Case Is > iLen
Soundex = Left(Result, iLen)
End Select
End If
End Function

Private Function Category(c) As String
'   Returns a Soundex code for a letter
    Select Case True
        Case c Like "[AEIOUY]"
            Category = "/"
        Case c Like "[BPFV]"
            Category = "1"
        Case c Like "[CSKGJQXZ]"
            Category = "2"
        Case c Like "[DT]"
            Category = "3"
        Case c = "L"
            Category = "4"
        Case c Like "[MN]"
            Category = "5"
        Case c = "R"
            Category = "6"
        Case Else 'This includes H and W, spaces, punctuation, etc.
            Category = ""
    End Select
End Function

Betrifft: Levenshtein VBA-Script von: Klaus M.vdT.
Geschrieben am: 23.09.2014 11:48:56

Hi nochmal,
falls dir SOUNDEX noch nicht hilft, hier die LEVENSHTEIN udf aus meiner Sammlung.
A1 = Batterie
A2 = Bakterie
A3 = Levenshtein3(A1;A2) ergibt, dass eine Batterie einer Bakterie zu 88% ähnlich ist.

Auch hier: Vor und Nachteile bitte selber ergooglen.

Option Explicit

' Levenshtein3 tweaked for UTLIMATE speed and CORRECT results
' Solution based on Longs
' Intermediate arrays holding Asc()make difference
' even Fixed length Arrays have impact on speed (small indeed)
' Levenshtein version 3 will return correct percentage
'
Function Levenshtein3(ByVal string1 As String, ByVal string2 As String) As Long

Dim i As Long, j As Long, string1_length As Long, string2_length As Long
Dim distance(0 To 60, 0 To 50) As Long, smStr1(1 To 60) As Long, smStr2(1 To 50) As Long
Dim min1 As Long, min2 As Long, min3 As Long, minmin As Long, MaxL As Long

string1_length = Len(string1):  string2_length = Len(string2)

distance(0, 0) = 0
For i = 1 To string1_length:    distance(i, 0) = i: smStr1(i) = Asc(LCase(Mid$(string1, i, 1))): _
 Next
For j = 1 To string2_length:    distance(0, j) = j: smStr2(j) = Asc(LCase(Mid$(string2, j, 1))): _
 Next
For i = 1 To string1_length
    For j = 1 To string2_length
        If smStr1(i) = smStr2(j) Then
            distance(i, j) = distance(i - 1, j - 1)
        Else
            min1 = distance(i - 1, j) + 1
            min2 = distance(i, j - 1) + 1
            min3 = distance(i - 1, j - 1) + 1
            If min2 < min1 Then
                If min2 < min3 Then minmin = min2 Else minmin = min3
            Else
                If min1 < min3 Then minmin = min1 Else minmin = min3
            End If
            distance(i, j) = minmin
        End If
    Next
Next

' Levenshtein3 will properly return a percent match (100%=exact) based on similarities and  _
Lengths etc...
MaxL = string1_length: If string2_length > MaxL Then MaxL = string2_length
Levenshtein3 = 100 - CLng((distance(string1_length, string2_length) * 100) / MaxL)

End Function

Beiträge aus den Excel-Beispielen zum Thema "Index mit ungefährer Übereinstimmung"