Listing 1
Function Soundex (ByVal pvarSurName As Variant) As Variant
'
'Copyright 1992, 1993 Paul Litwin.
'ALL RIGHTS RESERVED.
''
'Purpose:   Soundex takes a surname string and returns a 4-digit string
'           representing the Russell Soundex code.
'
'Author:    Paul Litwin
'Passed:    A surname (last name) as a variant.
'Returns:   A 4-digit Soundex code as a variant.

Dim intLength As Integer
Dim intCharCount As Integer
Dim intSdxCount As Integer
Dim intSeparator As Integer
Dim intSdxCode As Integer
Dim intPrvCode As Integer
Dim varCurrChar As Variant
Dim varSdx As Variant

On Error GoTo SoundexError

'If a null or empty string was passed, return a null
If IsNull(pvarSurName) Then
    varSdx = ""
    GoTo SoundexDone
Else
    intLength = Len(pvarSurName)
    If intLength = 0 Then
        varSdx = ""
        GoTo SoundexDone
    End If
End If

intSeparator = 0     'Keeps track of vowel separators
intPrvCode = 0       'The code of the previous char
intSdxCount = 0      'Counts number of soundex chars
intCharCount = 0     'Counts number of surname chars

'Loop until the soundex code is of length 4
'or we have run out of characters in the surname
Do Until (intSdxCount = 4 Or intCharCount = intLength)

intCharCount = intCharCount + 1
varCurrChar = Mid(pvarSurName, intCharCount, 1)

'Calculate the code for the current character
Select Case varCurrChar
    Case "B", "F", "P", "V"
        intSdxCode = 1
    Case "C", "G", "J", "K", "Q", "S", "X", "Z"
        intSdxCode = 2
    Case "D", "T"
        intSdxCode = 3
    Case "L"
        intSdxCode = 4
    Case "M", "N"
        intSdxCode = 5
    Case "R"
        intSdxCode = 6
    Case "A", "E", "I", "O", "U", "Y"
        intSdxCode = -1
    Case Else
        intSdxCode = -2
End Select

'Treat the first character specially
If intCharCount = 1 Then
    varSdx = UCase(varCurrChar)
    intSdxCount = intSdxCount + 1
    intPrvCode = intSdxCode
    intSeparator = 0

'If a significant constant and not a repeat
'without a separator then code this character
ElseIf intSdxCode > 0 And (intSdxCode <> intPrvCode Or intSeparator = 1) 
Then
    varSdx = varSdx + Format(intSdxCode, "#")
    intSdxCount = intSdxCount + 1
    intPrvCode = intSdxCode
    intSeparator = 0

'If a vowel, this character is not coded,
'but it will act as a separator
ElseIf intSdxCode = -1 Then
    intSeparator = 1
End If

Loop
    
'If the code is < 4 chars long, then
'fill the rest of code with zeros
If intSdxCount < 4 Then
    varSdx = varSdx + String((4 - intSdxCount), "0")
End If

SoundexDone:
    'Return the soundex code
    Soundex = varSdx
    On Error GoTo 0
    Exit Function

SoundexError:
    Select Case Err
    Case Else
        MsgBox "Error #" & Str(Err) & " encountered." & Chr(13) & 
Chr(13) & Error(Err), 0 + 16, "Soundex Error"
    End Select
    Resume Next

End Function

