'---------------------------------------------------------------------------------------
' Procedure : Soundex
' Author : Allen Browne
' Date : 04-10-2011
' Purpose : Fuzzy search Soundex search
'---------------------------------------------------------------------------------------
' Last Modified:
'
' Inputs: N/A
' Dependency: N/A
'--------------------------------------------------------------------------
'
Public Function Soundex(varText As Variant) As Variant
On Error GoTo Err_Handler
'Purpose: Return Soundex value for the text passed in.
'Return: Soundex code, or Null for Error, Null or zero-length string.
'Argument: The value to generate the Soundex for.
'Author: Allen Browne (allen@allenbrowne.com), November 2007.
'Algorithm: Based on
http://en.wikipedia.org/wiki/Soundex
Dim strSource As String 'varText as a string.
Dim strOut As String 'Output string to build up.
Dim strValue As String 'Value for current character.
Dim strPriorValue As String 'Value for previous character.
Dim lngPos As Long 'Position in source string
'Do not process Error, Null, or zero-length strings.
If Not IsError(varText) Then
strSource = Trim$(Nz(varText, vbNullString))
If strSource <> vbNullString Then
'Retain the initial character, and process from 2nd.
strOut = Left$(strSource, 1&)
strPriorValue = SoundexValue(strOut)
lngPos = 2&
'Examine a character at a time, until we output 4 characters.
Do
strValue = SoundexValue(Mid$(strSource, lngPos, 1&))
'Omit repeating values (except the zero for padding.)
If ((strValue <> strPriorValue) And (strValue <> vbNullString)) Or (strValue = "0") Then
strOut = strOut & strValue
strPriorValue = strValue
End If
lngPos = lngPos + 1&
Loop Until Len(strOut) >= 4&
End If
End If
'Return the output string, or Null if nothing generated.
If strOut <> vbNullString Then
Soundex = strOut
Else
Soundex = Null
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.number & ": " & Err.Description, vbExclamation, "Soundex()"
'Call LogError(Err.Number, Err.Description, conMod & ".Soundex")
Resume Exit_Handler
End Function
Private Function SoundexValue(strChar As String) As String
Select Case strChar
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 vbNullString
'Pad trailing zeros if no more characters.
SoundexValue = "0"
Case Else
'Return nothing for "A", "E", "H", "I", "O", "U", "W", "Y", non-alpha.
End Select
End Function