SOUNDEX in access

D

DAVID

Access supports VBA. You can copy a SOUNDEX function into your application.

Note that SOUNDEX was a function to help merge American family names a
hundred years ago.

If your data does not resemble American family names of the early
1900's, SOUNDEX is unlikely to be helpful.

There are replacements for SOUNDEX that handle different mixes of family
names, as might be used by a census in some other country, and that are
probably 'better' than the very old SOUNDEX algorithm anyway.

But note that name matching is very inexact however you do it: SOUNDEX
was just a way of making consistent guesses.

And if you are trying to match WORDS rather than NAMES, you can't get
there from here: word matching is very difficult, and a simple letter
algorithm is not going to work. A spelling dictionary wood bee much
better than a soundex algorithm.
 
A

Arvin Meyer [MVP]

SF said:
Hi,

I was wondering whether Access support SOUNDEX function or not?
Click to expand...

Sure, here are 2 of them, the first by Lyle Fairfield and the second, I
think by Joe Foster. Also a test:

Option Compare Database
Option Explicit

Sub test()
Debug.Print Soundex("Euler")
'E460
Debug.Print Soundex("Gauss")
'G200
Debug.Print Soundex("Hilbert")
'H416
Debug.Print Soundex("Knuth")
'K530
Debug.Print Soundex("Lloyd")
'L300
Debug.Print Soundex("Lukasiewicz")
'L222
End Sub

Public Function CSSoundex(ByVal rString As String) As String

Dim aChar(0 To 255) As String, varElement As Variant
Dim aString() As Byte, varByte As Variant, varPreviousByte As Byte,
booIsFirst As Boolean


For Each varElement In aChar
varElement = ""
Next varElement

aChar(66) = "1" 'B
aChar(70) = "1" 'F
aChar(80) = "1" 'P
aChar(86) = "1" 'V

aChar(67) = "2" 'C
aChar(71) = "2" 'G
aChar(74) = "2" 'J
aChar(75) = "2" 'K
aChar(81) = "2" 'Q
aChar(83) = "2" 'S
aChar(88) = "2" 'X
aChar(90) = "2" 'Z

aChar(68) = "3" 'D
aChar(84) = "3" 'T

aChar(76) = "4" 'L

aChar(77) = "5" 'M
aChar(78) = "5" 'M

aChar(82) = "6" 'R

rString = StrConv(rString, vbUpperCase)
aString = rString
booIsFirst = True

For Each varByte In aString
If booIsFirst Then
CSSoundex = Chr(varByte)
booIsFirst = False
varPreviousByte = varByte
ElseIf aChar(varByte) <> "" Then
If varByte <> varPreviousByte Then
CSSoundex = CSSoundex & aChar(varByte)
If Len(CSSoundex) = 4 Then Exit For
End If
varPreviousByte = varByte
End If
Next varByte
CSSoundex = Left(CSSoundex & "0000", 4)
End Function


Function Soundex(ByVal S As String) As String
S = UCase$(Trim$(S))
Dim Code As Integer: Code = 0
Dim Last As Integer: Last = 0
Dim R As String: R = ""
Dim i As Long: For i = 1 To Len(S)
Select Case Mid$(S, i, 1)
Case "B", "F", "P", "V"
Code = 1
Case "C", "G", "J", "K", "Q", "S", "X", "Z"
Code = 2
Case "D", "T"
Code = 3
Case "L"
Code = 4
Case "M", "N"
Code = 5
Case "R"
Code = 6
Case Else
Code = 0
End Select
If (i = 1) Then
R = Mid$(S, 1, 1)
ElseIf (Code <> 0 And Code <> Last) Then
R = R & Code
End If
Last = Code
Next i
Soundex = Mid$(R & "0000", 1, 4)
End Function
 
S

SF

Thank for the code.

Arvin Meyer said:
Sure, here are 2 of them, the first by Lyle Fairfield and the second, I
think by Joe Foster. Also a test:

Option Compare Database
Option Explicit

Sub test()
Debug.Print Soundex("Euler")
'E460
Debug.Print Soundex("Gauss")
'G200
Debug.Print Soundex("Hilbert")
'H416
Debug.Print Soundex("Knuth")
'K530
Debug.Print Soundex("Lloyd")
'L300
Debug.Print Soundex("Lukasiewicz")
'L222
End Sub

Public Function CSSoundex(ByVal rString As String) As String

Dim aChar(0 To 255) As String, varElement As Variant
Dim aString() As Byte, varByte As Variant, varPreviousByte As Byte,
booIsFirst As Boolean


For Each varElement In aChar
varElement = ""
Next varElement

aChar(66) = "1" 'B
aChar(70) = "1" 'F
aChar(80) = "1" 'P
aChar(86) = "1" 'V

aChar(67) = "2" 'C
aChar(71) = "2" 'G
aChar(74) = "2" 'J
aChar(75) = "2" 'K
aChar(81) = "2" 'Q
aChar(83) = "2" 'S
aChar(88) = "2" 'X
aChar(90) = "2" 'Z

aChar(68) = "3" 'D
aChar(84) = "3" 'T

aChar(76) = "4" 'L

aChar(77) = "5" 'M
aChar(78) = "5" 'M

aChar(82) = "6" 'R

rString = StrConv(rString, vbUpperCase)
aString = rString
booIsFirst = True

For Each varByte In aString
If booIsFirst Then
CSSoundex = Chr(varByte)
booIsFirst = False
varPreviousByte = varByte
ElseIf aChar(varByte) <> "" Then
If varByte <> varPreviousByte Then
CSSoundex = CSSoundex & aChar(varByte)
If Len(CSSoundex) = 4 Then Exit For
End If
varPreviousByte = varByte
End If
Next varByte
CSSoundex = Left(CSSoundex & "0000", 4)
End Function


Function Soundex(ByVal S As String) As String
S = UCase$(Trim$(S))
Dim Code As Integer: Code = 0
Dim Last As Integer: Last = 0
Dim R As String: R = ""
Dim i As Long: For i = 1 To Len(S)
Select Case Mid$(S, i, 1)
Case "B", "F", "P", "V"
Code = 1
Case "C", "G", "J", "K", "Q", "S", "X", "Z"
Code = 2
Case "D", "T"
Code = 3
Case "L"
Code = 4
Case "M", "N"
Code = 5
Case "R"
Code = 6
Case Else
Code = 0
End Select
If (i = 1) Then
R = Mid$(S, 1, 1)
ElseIf (Code <> 0 And Code <> Last) Then
R = R & Code
End If
Last = Code
Next i
Soundex = Mid$(R & "0000", 1, 4)
End Function
--
Arvin Meyer, MCP, MVP
http://www.datastrat.com
http://www.mvps.org/access
http://www.accessmvp.com
Click to expand...
 
Top