Sub testsoundex()
Dim str As Variant, str1 As Variant
Dim name1 As Variant, name As Variant
Dim nameset1 As Variant, nameset2 As Variant
Dim x As Integer, y As Integer
For x = 2 To 10
For y = x + 1 To 11
nameset1 = Range("X" & x)
nameset2 = Range("X" & y)
str = Left(nameset1, InStr(1, nameset1, " "))
str1 = Mid(nameset1, InStr(1, nameset1, " ") + 1, 50)
name = Soundex(str) & Soundex(str1)
'Debug.Print Soundex(str)
'Debug.Print Soundex(str1)
'Debug.Print name
str = Left(nameset2, InStr(1, nameset2, " "))
str1 = Mid(nameset2, InStr(1, nameset2, " ") + 1, 50)
name1 = Soundex(str) & Soundex(str1)
'Debug.Print Soundex(str)
'Debug.Print Soundex(str1)
'Debug.Print name1
Debug.Print nameset1, nameset2
If name = name1 Then
'Debug.Print "True"
Range("Y" & x) = "Match " & nameset2
Range("Y" & y) = "Match " & nameset1
'Else
'Debug.Print "False"
'Range("Y" & x) = ""
End If
Next y
Next x
End Sub
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((varText))
If strSource <> "" 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
