Kleine Code-Erweiterung benötigt
Frank
ich habe nach einigem Stöbern im Internet folgenden Code für das Soundex-Verfahren (Anzeige ähnlicher Werte) gefunden, der soweit super funktioniert.
Nun suche ich nur noch eine Lösung für folgendes Problem:
Zu Beginn des Codes soll überprüft werden, ob der Ausgangsbegriff Ziffern (0 bis 9), Leerzeichen (" ") oder Bindestriche ("-") enthält.
Falls ja, sollen diese Zeichen zunächst im Code durch nichts ("") ersetzt werden bzw. für das Soundex-Verfahren nicht berücksichtigt werden.
Kann mir jemand sagen, was ich hier noch ergänzen muss ?
Option Explicit
Option Private Module
Function Soundex2(text As String) As String
Dim strResult$, strOneChar$, intCode%, intLastCode%, intIndex%, intCount%
' Set default result
strResult = UCase(Left(text, 1)) & "000"
intCount = 2
For intIndex = 1 To Len(text)
strOneChar = LCase(Mid(text, intIndex, 1))
If strOneChar Like "[aeiouywhäöü]" Then
intCode = 0
ElseIf strOneChar Like "[bfpv]" Then
intCode = 1
ElseIf strOneChar Like "[cgjkqsxzß]" Then
intCode = 2
ElseIf strOneChar Like "[dt]" Then
intCode = 3
ElseIf strOneChar = "l" Then
intCode = 4
ElseIf strOneChar Like "[mn]" Then
intCode = 5
ElseIf strOneChar = "r" Then
intCode = 6
Else
intCode = -1
End If
If intCode -1 Then
' disallows duplicates
If intCode intLastCode Then
If intCode > 0 And intIndex > 1 Then
Mid(strResult, intCount, 1) = intCode
intCount = intCount + 1
If intCount > 4 Then Exit For
End If
intLastCode = intCode
End If
End If
Next intIndex
Soundex2 = strResult
End Function
Frank
Anzeige