It returns a list of names that are similar. So if I was to enter "vie", then it would return "vien", "viens", etc....if the names already existed. I am using it to find mis-spelled names.
This is the function.
Function Soundex(ByVal WordString As String, _
Optional SoundexLen As Integer = 4) As String
Dim Counter As Integer
Dim CurrChar As String
If SoundexLen > 10 Then
SoundexLen = 10
ElseIf SoundexLen < 4 Then
SoundexLen = 4
End If
SoundexLen = SoundexLen - 1
WordString = UCase(WordString)
For Counter = 1 To Len(WordString)
If Asc(Mid(WordString, Counter, 1)) < 65 Or _
Asc(Mid(WordString, Counter, 1)) > 90 Then
Mid(WordString, Counter, 1) = " "
End If
Next Counter
WordString = Trim(WordString)
If Len(Trim(WordString)) = 0 Then
Soundex = ""
Else
Soundex = WordString
Soundex = Replace(Soundex, "A", "0")
Soundex = Replace(Soundex, "E", "0")
Soundex = Replace(Soundex, "I", "0")
Soundex = Replace(Soundex, "O", "0")
Soundex = Replace(Soundex, "U", "0")
Soundex = Replace(Soundex, "Y", "0")
Soundex = Replace(Soundex, "H", "0")
Soundex = Replace(Soundex, "W", "0")
Soundex = Replace(Soundex, "B", "1")
Soundex = Replace(Soundex, "P", "1")
Soundex = Replace(Soundex, "F", "1")
Soundex = Replace(Soundex, "V", "1")
Soundex = Replace(Soundex, "C", "2")
Soundex = Replace(Soundex, "S", "2")
Soundex = Replace(Soundex, "G", "2")
Soundex = Replace(Soundex, "J", "2")
Soundex = Replace(Soundex, "K", "2")
Soundex = Replace(Soundex, "Q", "2")
Soundex = Replace(Soundex, "X", "2")
Soundex = Replace(Soundex, "Z", "2")
Soundex = Replace(Soundex, "D", "3")
Soundex = Replace(Soundex, "T", "3")
Soundex = Replace(Soundex, "L", "4")
Soundex = Replace(Soundex, "M", "5")
Soundex = Replace(Soundex, "N", "5")
Soundex = Replace(Soundex, "R", "6")
CurrChar = Left(Soundex, 1)
For Counter = 2 To Len(Soundex)
If Mid(Soundex, Counter, 1) = CurrChar Then
Mid(Soundex, Counter, 1) = " "
Else
CurrChar = Mid(Soundex, Counter, 1)
End If
Next Counter
Soundex = Replace(Soundex, " ", "")
Soundex = Mid(Soundex, 2)
Soundex = Replace(Soundex, "0", "")
Soundex = Soundex & String(SoundexLen, "0")
Soundex = Left(WordString, 1) & Left(Soundex, SoundexLen)
End If
End Function