Hallo,
ich möchte mittels Soundex-Algorithmus aus einem Namen einen z. B. 4-stelligen Code erzeugen. Hat jemand einen VBA-Code zur Verfügung?
Am besten wäre es, wenn der Algorithmus an die deutsche Sprache angepasst ist und/oder mehr als 6 phonetische Klassen hätte.
Grüsse
Peter
Hallo,
Hi,
bin kein Sprachwissenschaftler, daher kannst du dir die phonetischen Klassen alleine bilden.
Habe dir aber den Soundex-Algo umgesetzt (nach der Wikipedia-Definition http://de.wikipedia.org/wiki/Soundex )
Public Function soundex(wort As String)
Dim i As Integer
Dim merker As Integer
i = 2
soundex = UCase(Mid(wort, 1, 1))
While Len(wort) \>= i And Len(soundex) 0 Then soundex = soundex & "1"
If InStr(1, "cgjkqsßxz", LCase(Mid(wort, i, 1))) \> 0 Then soundex = soundex & "2"
If InStr(1, "dt", LCase(Mid(wort, i, 1))) \> 0 Then soundex = soundex & "3"
If InStr(1, "l", LCase(Mid(wort, i, 1))) \> 0 Then soundex = soundex & "4"
If InStr(1, "mn", LCase(Mid(wort, i, 1))) \> 0 Then soundex = soundex & "5"
If InStr(1, "", LCase(Mid(wort, i, 1))) \> 0 Then soundex = soundex & "6"
If Len(soundex) \> 1 Then
If Mid(soundex, Len(soundex), 1) = Mid(soundex, Len(soundex) - 1, 1) Then
soundex = Mid(soundex, 1, Len(soundex) - 1)
End If
End If
i = i + 1
Wend
soundex = soundex & String(4 - Len(soundex), "0")
End Function
Gruß.Timo
ich möchte mittels Soundex-Algorithmus aus einem Namen einen
z. B. 4-stelligen Code erzeugen. Hat jemand einen VBA-Code zur
Verfügung?
Am besten wäre es, wenn der Algorithmus an die deutsche
Sprache angepasst ist und/oder mehr als 6 phonetische Klassen
hätte.Grüsse
Peter
Korrektur
Hi,
habe noch einen Punkt der Konventionen vergessen.
Public Function soundex(wort As String)
Dim i As Integer
Dim merker As String
i = 2
soundex = UCase(Mid(wort, 1, 1))
While Len(wort) \>= i And Len(soundex) 0 Then soundex = soundex & "1"
If InStr(1, "cgjkqsßxz", LCase(Mid(wort, i, 1))) \> 0 Then soundex = soundex & "2"
If InStr(1, "dt", LCase(Mid(wort, i, 1))) \> 0 Then soundex = soundex & "3"
If InStr(1, "l", LCase(Mid(wort, i, 1))) \> 0 Then soundex = soundex & "4"
If InStr(1, "mn", LCase(Mid(wort, i, 1))) \> 0 Then soundex = soundex & "5"
If InStr(1, "", LCase(Mid(wort, i, 1))) \> 0 Then soundex = soundex & "6"
If Len(soundex) \> 1 And InStr(1, "aeiouy", merker) = 0 And i \> 2 Then
If Mid(soundex, Len(soundex), 1) = Mid(soundex, Len(soundex) - 1, 1) Then
soundex = Mid(soundex, 1, Len(soundex) - 1)
End If
End If
merker = Mid(wort, i, 1)
i = i + 1
Wend
soundex = soundex & String(4 - Len(soundex), "0")
End Function
Gruß.Timo
Hallo Timo,
vielen Dank für Die prompte Hilfe. Beim Aufruf wie folgt bekam ich eine Fehermeldung mit ‚ByRef‘ (Werte werden aus einer Excel-Spalte eingesetzt). Erst nachdem ich mit doppelter Klammer codierte funktionierte es. An was könnte das liegen?
Grüsse
Peter
Private Sub CmdSoundex_Click()
Dim Eingabe, Ausgabe As String
Dim i As Byte
For i = 7 To 20
Eingabe = ThisWorkbook.Worksheets(1).Cells(i, 2).Value
Ausgabe = SoundEx(Eingabe)
ThisWorkbook.Worksheets(1).Cells(i, 4).Value = Ausgabe
Next i
End Sub
Moin!
Es gibt Situationen, in denen VB nicht mit der Variablenübergabe als ByRef klarkommt. (ByRef bedeutet, es wird nicht der Wert, sondern ein Zeiger auf den Wert an die Funktion übergeben). Variable könnten von der Funktion, der sie „ByRef“ übergeben wurden verändert werden. Durch das Einklammern des übergebenen Wertes hast du exlpizit ein ByVal (Übergabe als Wert, die Original-Variable bleibt unangetastet) erzwungen.
Alternativ könnte Deine Funktion so definiert sein:
public function Soundex(ByVal TEXT as String) as String
dann könntest Du Dir die Extra-Klammern sparen, der Parameter wird immer als Wert übergeben.
Gruß aus dem hohen Norden
Sven
[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]