VBA Metaphonics implementation v1
An implemenation of the standard Metaphonics algorithm in VBA. It takes words (or sentences) and converts them to high-level phonics so they can be compared. Example applications might include matching user databases (where mis-spellings might be common) and other fuzzy string matching situations. I might develop this further to provide a % match score where the phonics are not exactly equal; if interest in this is expressed then I’ll get on with it.
A metaphone is generated by calling the function metaphone() with the word in question as an argument, e.g. debug.print(metaphone("hello")) will output the metaphone for “hello”. Crudely, you can compare metaphones for similarity with the function theSame(), e.g. debug.print(theSame("hello","helo")) will output True. Feedback welcome!
Public Function metaphone(word)
metaphoneOutput = ""
Dim a()
Dim b As Variant
x = 1
If InStr(1, word, " ") Then
b = Split(word, " ")
For Each c In b
metaphoneOutput = metaphoneOutput + metaphone(c)
Next c
metaphone = metaphoneOutput
Exit Function
End If
While x < = Len(word)
a = makeMetaphone(word, x)
x = x + Len(a(0))
metaphoneOutput = metaphoneOutput + a(0)
Wend
'remove repeats
For x = 1 To Len(metaphoneOutput) - 1
If Mid(metaphoneOutput, x, 1) = Mid(metaphoneOutput, x + 1, 1) Then Mid(metaphoneOutput, x, 1) = "_"
Next x
'remove blanks
metaphoneOutput = Replace(metaphoneOutput, "_", "")
metaphone = metaphoneOutput
End Function
Private Function makeMetaphone(word, letter)
Dim a(1)
Dim nl(4)
word = UCase(word)
For x = 1 To 4
If (x + letter - 1) <= Len(word) Then nl(x) = Left(Right(word, 1 + Len(word) - letter), x) Else nl(x) = ""
Next x
If x > 1 Then nl(0) = Mid(word, x - 1, 1) Else nl(0) = ""
Select Case nl(1)
Case "A", "E", "I", "O", "U":
If letter = 1 Or nl(0) = " " Then
a(0) = nl(1)
Else
a(0) = "_"
End If
Case "F", "J", "L", "M", "N", "R", "0" To "9":
a(0) = nl(1)
Case "W", "Y"
If InStr(2, "AEIOU", Right(nl(2), 1)) Then a(0) = nl(1) Else a(0) = "_"
Case "X"
If nl(2) = "XI" And (letter < (Len(word) - 1)) Then
a(0) = "S_"
Else
a(0) = "KS"
End If
Case "Z"
a(0) = "S"
Case "V"
a(0) = "F"
Case "T"
If nl(3) = "TIA" Or nl(3) = "TIO" Then
a(0) = "X__"
ElseIf nl(3) = "TCH" Then
a(0) = "___"
ElseIf nl(2) = "TH" Then
a(0) = "0_"
Else
a(0) = "T"
End If
Case "S"
If nl(2) = "SH" Then
a(0) = "X_"
ElseIf nl(3) = "SIO" Or nl(3) = "SIA" Then
a(0) = "X__"
Else
a(0) = "S"
End If
Case "Q":
a(0) = "K"
Case "P":
If nl(2) = "PH" Then
a(0) = "F_"
Else
a(0) = "P"
End If
Case "K":
If nl(0) = "C" Then
a(0) = "_"
Else
a(0) = "K"
End If
Case "H":
If InStr(1, "AEIOU", nl(0)) And InStr(1, "AEIOU", Right(nl(2), 1)) Then
a(0) = "_"
Else
a(0) = "H"
End If
Case "G":
If nl(2) = "GH" And (letter < (Len(word) - 1) And Not InStr(1, "AEIOU", Right(nl(2), 1))) Then
a(0) = "_"
ElseIf InStr(1, "IEY", Right(nl(2), 1)) And nl(0) <> "G" Then
a(0) = "J"
Else
a(0) = "K"
End If
Case "D":
If nl(3) = "DGE" Or nl(3) = "DGY" Or nl(3) = "DGI" Then
a(0) = "J__"
Else
a(0) = "T"
End If
Case "C":
If nl(3) = "CIA" Or nl(2) = "CH" Then
a(0) = "X_"
ElseIf nl(2) = "CI" Or nl(2) = "CE" Or nl(2) = "CY" Then
a(0) = "S_"
Else
a(0) = "K"
End If
Case "B":
If nl(0) = "M" And letter = Len(word) Then
a(0) = "_"
Else
a(0) = "B"
End If
Case Else
a(0) = "_"
End Select
makeMetaphone = a
End Function
Public Function theSame(word1, word2)
If metaphone(word1) = metaphone(word2) Then theSame = True Else theSame = False
End Function
July 27th, 2005 at 2:35 pm
[...] http://www.tcbutler.co.uk/vba-metaphonics-implementation-v1/ [...]