Function RSOUNDEX(ByVal strInput As String) As String
    '2009-Jun-05
    'This is based on the Russell Soundex algorithm, and returns a string of up to four characters
    'that holds the Soundex value
    'Vowels exist only as dividers.  Consecutive consonants with matching Soundex values are treated
    'as one occurrence.  W and H only have an effect as the initial letter.
    
    Dim strThisChar As String * 1
    Dim strPrevChar As String * 1
    Dim strSoundex As String * 1
    Dim strOut As String
    Dim strWork As String
    Const cintSLen As Integer = 4
    
    strOut = Left(UCase(strInput), 1)
    strWork = UCase(Right(strInput, Len(strInput) - 1))
    strThisChar = Left(strWork, 1)
    strWork = Right(strWork, Len(strWork) - 1) & " "
    strPrevChar = strOut
    
    Do Until Len(strOut) = cintSLen Or strWork = ""
        
        'strThisChar = Left(strWork, 1)
        
        'Get the Soundex value for this letter
        strSoundex = SoundexValue(strThisChar)
        
        If Not (strSoundex = " " Or strSoundex = SoundexValue(strPrevChar)) Then
            
            strOut = strOut & strSoundex
        
        End If
        
        strPrevChar = strThisChar
        strThisChar = Left(strWork, 1)
        strWork = Right(strWork, Len(strWork) - 1)
        
    Loop
    
    RSOUNDEX = strOut
    
End Function

Function SoundexValue(strLetter As String) As String
'2009-Jun-06
'Return the soundex value of the supplied letter

Select Case strLetter
    
    Case "A", "E", "H", "I", "O", "U", "W"
        
        SoundexValue = ""
    
    Case "B", "F", "P", "V"
        
        SoundexValue = "1"
    
    Case "C", "G", "J", "K", "Q", "S", "X", "Z"
        
        SoundexValue = "2"
    
    Case "D", "T"
        
        SoundexValue = "3"
    
    Case "L"
        
        SoundexValue = "4"
    
    Case "M", "N"
        
        SoundexValue = 5
    
    Case "R"
        
        SoundexValue = "6"
    
    Case Else
        
        SoundexValue = ""
    
End Select
    
End Function

Function RSOUNDEXCOMP(strVal1 As String, strVal2 As String, Optional booSoundex As Boolean = False) As Integer
    '2009-Jun-08
    'Function sort of taken from Getz & Gilbert "VBA Developer's Handbook" 2nd edition
    'Convert the values into Soundex values if required and report how similar they are
    
    Dim intLoop As Integer
    
    If Not booSoundex Then
        
        strVal1 = RSOUNDEX(strVal1)
        strVal2 = RSOUNDEX(strVal2)
    
    End If
    
    If strVal2 = strVal1 Then
        
        RSOUNDEXCOMP = 4
        
        Exit Function
    
    End If
    
    For intLoop = 1 To cintSLen
        
        If Mid(strVal1, intLoop, 1) <> Mid(strVal2, intLoop, 2) Then
            
            Exit For
        
        End If
    
    Next intLoop
    
    RSOUNDEXCOMP = intLoop - 1
    
End Function