Option Explicit
'************************************************************************************************************
'** Functions available are:
'** FuzzyCount
'** ==========
'** Utility giving a simple count of (Fuzzy) Matching strings equal to or above NFPercent threshold
'** Parameters are
'** LookupValue: Mandatory String
'** TableArray : Mandatory Range
'** NFPercent : Minimum %age match for the entry to be deemed as matching. Default 5%
'** Algorithm : Algorithm to be used, default 3
'**
'** FuzzyPercent
'** ============
'** Return a percentage match on two strings
'** Parameters are
'** String1 : Mandatory first string to be compared
'** String2 : Mandatory second string to be compared
'** Algorithm : Algorithm to be used for comparison, default 3
'** This parameter can take one of the following values:
'** Algorithm = 1:
'** This algorithm is best suited for matching mis-spellings.
'** For each character in 'String1', a search is performed on 'String2'.
'** The search is deemed successful if a character is found in 'String2'
'** within 3 characters of the current position.
'** A score is kept of matching characters which is returned as a
'** percentage of the total possible score.
'** Algorithm = 2:
'** This algorithm is best suited for matching sentences, or
'** 'firstname lastname' compared with 'lastname firstname' combinations
'** A count of matching pairs, triplets, quadruplets etc. in 'String1' and
'** 'String2' is returned as a percentage of the total possible.
'** Algorithm = 3:
'** Both Algorithms 1 and 2 are performed. **
'** Algorithm = 4:
'** Levenshtein Distance algorithm is used.
'** Algorithm = 'Soundex'
'** Soundex rules are applied, see http://www.j-walk.com/ss/excel/tips/tip77.htm
'** If the 'normalised' strings exactly match, 100% is returned,
'** If the strings converted to Soundex code match, (an arbitrary) 95% match is returned
'** If the Soundex strings do not match, 0% is returned.
'** Algorithm = 'Metaphone'
'** Basic Metaphone rules are applied, see
'** If the 'normalised' strings exactly match, 100% is returned,
'** If the strings converted to Basic Metaphone code match, (an arbitrary) 95% match is returned
'** If the Basic Metaphone strings do not match, 0% is returned.
'** Normalised: For efficiency set this boolean to True if both strings have been 'Normalised'
'** A Normalised string has been converted to all lower or all upper case,
'** and has all leading, trailing and multiple internal spaces removed.
'** Default False.
'** FuzzyVLookup
'** ============
'** Function to Fuzzy match LookupValue with entries in specified column (default 1)
'** of lookup table specified by TableArray.
'** Parameters are
'** LookupValue: Value to be matched
'** TableArray : Look up table
'** IndexNum : The column number of the entry in TableArray required to be
'** returned, as follows:
'** If IndexNum > 0 and the 'Rank' percentage match is >= NFPercent
'** (Default 5%) the column entry indicated by IndexNum is returned.
'** if IndexNum = 0 and the 'Rank' percentage match is >= NFPercent
'** (Default 5%) the corresponding value in the offset row (starting at 1
'** is returned. This returned value can be used to directly feed the 'Index' function.
'** NFPercent : This parameter defines the percentage below which two strings are
'** defined as not matching, and can be expressed as either a value between 0.001 to 1
'** or an integer between 2 and 100 optionally followed by '%'
'** The parameter can optionally be followed by a seperator '~' and then
'** a 'high' percentage value (default 100%), above which a string is not considered
'** a candidate for matching.
'** Valid examples of this parametert are:
'** .5 - Entries below 50% match are ignored
'** 50 - Entries below 50% match are ignored
'** 50% - Entries below 50% match are ignored
'** 50~99 - Only entries between 50% and 99% are candidates for matching
'** 50%~.99 - Only entries between 50% and 99% are candidates for matching
'** If no entries are equal to or above NFPercent, #N/A is returned.
'** Rank : Defines the value(s) to be returned within the NFPercent range.
'** This parameter is specified as an integer defining which value is to be returned.
'** The integer can optiolnally be followed by a string and another rank integer.
'** Ifd this is the case, the function will return each value within the rank range,
'** seperated by the non-numeric string
'** For example the value "1, 10" (without the quotes) will return the best to the 10th
'** best matching values, seperated by comma and space, with highest ranking to lowest ranking.
'** And the value "10 1" (without the quotes) will return the 10th
'** best matching value to the best matching value, seperated by a space.
'** If the 'Rank' match percentage is lower than NFPercent #N/A is returned.
'** Algorithm : Described in FuzzyPercent
'** AdditionalCols: Defines additionbal columns within the lookup table which are to be concatenated
'** before matching the lookup value. Default 0.
'** LookupColOffset: Defines offset position within the lookup table of the value(s) to be compared
'** Default 0.
'** The following parameters allow matching by group, and only those values
'** which are in the group specified will be considered for matching.
'** GroupColOffset: This parameter specifies the offset column which contains the group values.
'** To trigger group matching, this must be a non-zero integer
'** GroupValue : This parameter specifies the Group to be considered for matching
'** GetLevenshteinPercentMatch
'** ==========================
'** Return a percentage match on two strings using the Levenshtein distance method.
'** This is the function called by FuzzyVLookup if Algorithm is set to 4.
'** Parameters are
'** String1 : Mandatory first string to be compared
'** String2 : Mandatory second string to be compared
'** Normalised: For efficiency set this boolean to True if both strings have been 'Normalised'
'** A Normalised string has been converted to all lower or all upper case,
'** and has all leading, trailing and multiple internal spaces removed.
'** Default False.
'** LevenshteinDistance
'** ===================
'** Compute Levenshtein Distance between two strings.
'** Parameters are
'** String1 : Mandatory first string to be compared
'** String2 : Mandatory second string to be compared
'************************************************************************************************************
Type RankInfo
Offset As Long
Percentage As Single
End Type
Dim mudRankData() As RankInfo
Dim mlBestMatchPtr As Long
Const msngSoundexMatchPercent As Single = 0.95 'Return 95% match for strings which Soundex match
Const msngMetaphoneMatchPercent As Single = 0.95 'Return 95% match for strings which match according to Basic Metaphone rules
'Dim TopMatch As Long
'Dim strCompare As String
Function FuzzyCount(ByVal LookupValue As String, _
ByVal TableArray As Range, _
Optional NFPercent As Single = 0.05, _
Optional Algorithm As Variant = 3) As Long
'**********************************************************************
'** Simple count of (Fuzzy) Matching strings >= NFPercent threshold **
'**********************************************************************
Dim lMatchCount As Long
Dim rCur As Range
Dim sString1 As String
Dim sString2 As String
'** Normalise lookup value **
sString1 = LCase$(Application.Trim(LookupValue))
For Each rCur In Intersect(TableArray.Resize(, 1), Sheets(TableArray.Parent.Name).UsedRange)
'** Normalise current Table entry **
sString2 = LCase$(Application.Trim(CStr(rCur)))
If sString2 <> "" Then
If FuzzyPercent(String1:=sString1, _
String2:=sString2, _
Algorithm:=Algorithm, _
Normalised:=False) >= NFPercent Then
lMatchCount = lMatchCount + 1
End If
End If
Next rCur
FuzzyCount = lMatchCount
End Function
Function FuzzyPercent(ByVal String1 As String, _
ByVal String2 As String, _
Optional Algorithm As Variant = 3, _
Optional Normalised As Boolean = False) As Single
'*************************************
'** Return a % match on two strings **
'*************************************
Dim bSoundex As Boolean
Dim bBasicMetaphone As Boolean
Dim intLen1 As Integer, intLen2 As Integer
Dim intCurLen As Integer
Dim intTo As Integer
Dim intPos As Integer
Dim intPtr As Integer
Dim intScore As Integer
Dim intTotScore As Integer
Dim intStartPos As Integer
Dim lngAlgorithm As Long
Dim sngScore As Single
Dim strWork As String
bSoundex = LCase$(CStr(Algorithm)) = "soundex"
bBasicMetaphone = LCase$(CStr(Algorithm)) = "metaphone"
'-------------------------------------------------------
'-- If strings havent been normalised, normalise them --
'-------------------------------------------------------
If Normalised = False Then
If bSoundex Or bBasicMetaphone Then
String1 = NormaliseStringAtoZ(String1)
String2 = NormaliseStringAtoZ(String2)
Else
String1 = LCase$(Application.Trim(String1))
String2 = LCase$(Application.Trim(String2))
End If
End If
'----------------------------------------------
'-- Give 100% match if strings exactly equal --
'----------------------------------------------
If String1 = String2 Then
FuzzyPercent = 1
Exit Function
End If
If bSoundex Then
String1 = Soundex(Replace(String1, " ", ""))
String2 = Soundex(Replace(String2, " ", ""))
If String1 = String2 Then
FuzzyPercent = msngSoundexMatchPercent
Else
FuzzyPercent = 0
End If
Exit Function
ElseIf bBasicMetaphone Then
String1 = Metaphone1(String1)
String2 = Metaphone1(String2)
If String1 = String2 Then
FuzzyPercent = msngMetaphoneMatchPercent
Else
FuzzyPercent = 0
End If
Exit Function
End If
intLen1 = Len(String1)
intLen2 = Len(String2)
If intLen1 = 0 Or intLen2 = 0 Then
FuzzyPercent = 0
Exit Function
End If
'----------------------------------------
'-- Give 0% match if string length < 2 --
'----------------------------------------
If intLen1 < 2 Then
FuzzyPercent = 0
Exit Function
End If
intTotScore = 0 'initialise total possible score
intScore = 0 'initialise current score
lngAlgorithm = Val(Algorithm)
'--------------------------------------------------------
'-- If Algorithm = 1 or 3, Search for single characters --
'--------------------------------------------------------
If (lngAlgorithm And 1) <> 0 Then
If intLen1 < intLen2 Then
FuzzyAlg1 String1, String2, intScore, intTotScore
Else
FuzzyAlg1 String2, String1, intScore, intTotScore
End If
End If
'-----------------------------------------------------------
'-- If Algorithm = 2 or 3, Search for pairs, triplets etc. --
'-----------------------------------------------------------
If (lngAlgorithm And 2) <> 0 Then
If intLen1 < intLen2 Then
FuzzyAlg2 String1, String2, intScore, intTotScore
Else
FuzzyAlg2 String2, String1, intScore, intTotScore
End If
End If
'-------------------------------------------------------------
'-- If Algorithm = 4,5,6,7, use Levenstein Distance method --
'-- (Algorithm 4 was Dan Ostrander's code) --
'-------------------------------------------------------------
If (lngAlgorithm And 4) <> 0 Then
If intLen1 < intLen2 Then
' sngScore = FuzzyAlg4(String1, String1)
sngScore = GetLevenshteinPercentMatch(String1:=String1, _
String2:=String2, _
Normalised:=True)
Else
' sngScore = FuzzyAlg4(String2, String1)
sngScore = GetLevenshteinPercentMatch(String1:=String2, _
String2:=String1, _
Normalised:=True)
End If
intScore = intScore + (sngScore * 100)
intTotScore = intTotScore + 100
End If
FuzzyPercent = intScore / intTotScore
End Function
Private Sub FuzzyAlg1(ByVal String1 As String, _
ByVal String2 As String, _
ByRef Score As Integer, _
ByRef TotScore As Integer)
Dim intLen1 As Integer, intPos As Integer, intPtr As Integer, intStartPos As Integer
intLen1 = Len(String1)
TotScore = TotScore + intLen1 'update total possible score
intPos = 0
For intPtr = 1 To intLen1
intStartPos = intPos + 1
intPos = InStr(intStartPos, String2, Mid$(String1, intPtr, 1))
If intPos > 0 Then
If intPos > intStartPos + 3 Then 'No match if char is > 3 bytes away
intPos = intStartPos
Else
Score = Score + 1 'Update current score
End If
Else
intPos = intStartPos
End If
Next intPtr
End Sub
Private Sub FuzzyAlg2(ByVal String1 As String, _
ByVal String2 As String, _
ByRef Score As Integer, _
ByRef TotScore As Integer)
Dim intCurLen As Integer, intLen1 As Integer, intTo As Integer, intPtr As Integer, intPos As Integer
Dim strWork As String
intLen1 = Len(String1)
For intCurLen = 1 To intLen1
strWork = String2 'Get a copy of String2
intTo = intLen1 - intCurLen + 1
TotScore = TotScore + Int(intLen1 / intCurLen) 'Update total possible score
For intPtr = 1 To intTo Step intCurLen
intPos = InStr(strWork, Mid$(String1, intPtr, intCurLen))
If intPos > 0 Then
Mid$(strWork, intPos, intCurLen) = String$(intCurLen, &H0) 'corrupt found string
Score = Score + 1 'Update current score
End If
Next intPtr
Next intCurLen
End Sub
'Private Function FuzzyAlg4(strIn1 As String, strIn2 As String) As Single
'
'Dim L1 As Integer
'Dim In1Mask(1 To 24) As Long 'strIn1 is 24 characters max
'Dim iCh As Integer
'Dim N As Long
'Dim strTry As String
'Dim strTest As String
'
'TopMatch = 0
'L1 = Len(strIn1)
'strTest = UCase(strIn1)
'strCompare = UCase(strIn2)
'For iCh = 1 To L1
' In1Mask(iCh) = 2 ^ iCh
'Next iCh 'Loop thru all ordered combinations of characters in strIn1
'For N = 2 ^ (L1 + 1) - 1 To 1 Step -1
' strTry = ""
' For iCh = 1 To L1
' If In1Mask(iCh) And N Then
' strTry = strTry & Mid(strTest, iCh, 1)
' End If
' Next iCh
' If Len(strTry) > TopMatch Then FuzzyAlg4Test strTry
'Next N
'FuzzyAlg4 = TopMatch / CSng(L1)
'End Function
'Sub FuzzyAlg4Test(strIn As String)
'
'Dim l As Integer
'Dim strTry As String
'Dim iCh As Integer
'
'l = Len(strIn)
'If l <= TopMatch Then Exit Sub
'strTry = "*"
'For iCh = 1 To l
' strTry = strTry & Mid(strIn, iCh, 1) & "*"
'Next iCh
'If strCompare Like strTry Then
' If l > TopMatch Then TopMatch = l
'End If
'End Sub
Public Function GetLevenshteinPercentMatch(ByVal String1 As String, _
ByVal String2 As String, _
Optional Normalised As Boolean = False) As Single
Dim iLen As Integer
If Normalised = False Then
String1 = UCase$(WorksheetFunction.Trim(String1))
String2 = UCase$(WorksheetFunction.Trim(String2))
End If
iLen = WorksheetFunction.Max(Len(String1), Len(String2))
GetLevenshteinPercentMatch = (iLen - LevenshteinDistance(String1, String2)) / iLen
End Function
''*******************************
''*** Get minimum of three values
''*******************************
'
'Private Function Minimum(ByVal a As Integer, _
' ByVal b As Integer, _
' ByVal c As Integer) As Integer
'Dim mi As Integer
'
' mi = a
' If b < mi Then
' mi = b
' End If
' If c < mi Then
' mi = c
' End If
'
' Minimum = mi
'
'End Function
'********************************
'*** Compute Levenshtein Distance
'********************************
Public Function LevenshteinDistance(ByVal s As String, ByVal t As String) As Integer
Dim d() As Integer ' matrix
Dim m As Integer ' length of t
Dim N As Integer ' length of s
Dim I As Integer ' iterates through s
Dim j As Integer ' iterates through t
Dim s_i As String ' ith character of s
Dim t_j As String ' jth character of t
Dim cost As Integer ' cost
' Step 1
N = Len(s)
m = Len(t)
If N = 0 Then
LevenshteinDistance = m
Exit Function
End If
If m = 0 Then
LevenshteinDistance = N
Exit Function
End If
ReDim d(0 To N, 0 To m) As Integer
' Step 2
For I = 0 To N
d(I, 0) = I
Next I
For j = 0 To m
d(0, j) = j
Next j
' Step 3
For I = 1 To N
s_i = Mid$(s, I, 1)
' Step 4
For j = 1 To m
t_j = Mid$(t, j, 1)
' Step 5
If s_i = t_j Then
cost = 0
Else
cost = 1
End If
' Step 6
d(I, j) = WorksheetFunction.Min(d(I - 1, j) + 1, d(I, j - 1) + 1, d(I - 1, j - 1) + cost)
Next j
Next I
' Step 7
LevenshteinDistance = d(N, m)
End Function
Function FuzzyVLookup(ByVal LookupValue As String, _
ByVal TableArray As Range, _
ByVal IndexNum As Integer, _
Optional NFPercent As String = "5%", _
Optional Rank As String = "1", _
Optional Algorithm As Variant = 3, _
Optional AdditionalCols As Integer = 0, _
Optional LookupColOffset As Integer = 0, _
Optional GroupColOffset As Integer = 0, _
Optional GroupValue As Variant = "") As Variant
'********************************************************************************
'** Function to Fuzzy match LookupValue with entries in **
'** table specified by TableArray. **
'********************************************************************************
Dim bWanted As Boolean
Dim bError As Boolean
Dim iPtr1 As Integer
Dim iPtr2 As Integer
Dim iaRank() As Integer
Dim iaRankLowHigh() As Integer
Dim iRankHigh As Integer
Dim iRankLow As Long
Dim iRankStep As Integer
Dim lEndRow As Long
Dim rCur As Range
Dim rSearchRange As Range
Dim sngNFPercent As Single
Dim sngaNFPercent() As Single
Dim sChar As String
Dim sPrevChar As String
Dim sRankDelimiter As String
Dim sResult As String
Dim strNFPercent As String
Dim straNFPercent() As String
Dim vCurValue As Variant
Dim wsTable As Worksheet
'--------------------------------------------------------------
'-- Validation --
'--------------------------------------------------------------
LookupValue = LCase$(Application.Trim(LookupValue))
If IsNumeric(Algorithm) = False Then
If LCase$(CStr(Algorithm)) = "soundex" Then
Algorithm = "soundex"
ElseIf LCase$(CStr(Algorithm)) = "metaphone" Then
Algorithm = "metaphone"
Else
FuzzyVLookup = "*** 'Algorithm' parameter invalid ***"
Exit Function
End If
End If
If IsMissing(NFPercent) Then
sngaNFPercent(0) = 0.05
sngaNFPercent(1) = 1
' sngMinPercent = 0.05
' sngMaxPercent = 1
Else
straNFPercent = Split(NFPercent, "~")
ReDim sngaNFPercent(0 To 1)
If UBound(straNFPercent) = 0 Then
ReDim Preserve straNFPercent(0 To 1)
straNFPercent(1) = "1"
End If
For iPtr1 = 0 To 1
sngaNFPercent(iPtr1) = Val(straNFPercent(iPtr1))
If sngaNFPercent(iPtr1) > 1 Then sngaNFPercent(iPtr1) = sngaNFPercent(iPtr1) / 100
If (sngaNFPercent(iPtr1) <= 0) Or (sngaNFPercent(iPtr1) > 1) Then
FuzzyVLookup = "*** 'NFPercent' is invalid ***"
Exit Function
End If
Next iPtr1
sngNFPercent = sngaNFPercent(0)
If sngaNFPercent(0) > sngaNFPercent(1) Then
sngNFPercent = sngaNFPercent(1)
sngaNFPercent(1) = sngaNFPercent(0)
sngaNFPercent(0) = sngNFPercent
End If
End If
ReDim iaRank(1 To 2)
sRankDelimiter = ""
If IsNumeric(Rank) Then
iaRank(1) = Val(Rank)
iaRank(2) = iaRank(1)
iRankLow = iaRank(1)
iRankHigh = iaRank(1)
If iaRank(1) < 1 Then
FuzzyVLookup = "*** 'Rank' must be a positive integer or format integer-delimiter-integer ***"
Exit Function
End If
iRankStep = 1
Else
iPtr2 = 1
sPrevChar = "0"
For iPtr1 = 1 To Len(Rank)
sChar = Mid$(Rank, iPtr1, 1)
If IsNumeric(sChar) Then
iaRank(iPtr2) = (iaRank(iPtr2) * 10) + Val(sChar)
Else
If IsNumeric(sPrevChar) Then
If iPtr2 = 2 Then Exit For
iPtr2 = 2
End If
sRankDelimiter = sRankDelimiter & sChar
End If
sPrevChar = sChar
Next iPtr1
bError = False
If iaRank(1) < 1 Then bError = True
If iaRank(2) < 1 Then bError = True
If bError Then
FuzzyVLookup = "*** 'Rank' must be a positive integer or format integer-delimiter-integer ***"
Exit Function
End If
If iaRank(2) < iaRank(1) Then
iRankStep = -1
iRankLow = iaRank(2)
iRankHigh = iaRank(1)
Else
iRankStep = 1
iRankLow = iaRank(1)
iRankHigh = iaRank(2)
End If
End If
Set wsTable = Sheets(TableArray.Parent.Name)
ReDim mudRankData(1 To iRankHigh)
lEndRow = TableArray.Rows.Count
If VarType(TableArray.Cells(lEndRow, 1).Value) = vbEmpty Then
lEndRow = TableArray.Cells(lEndRow, 1).End(xlUp).Row
End If
Set rSearchRange = Intersect(TableArray.Resize(, 1), wsTable.UsedRange)
If rSearchRange Is Nothing Then
FuzzyVLookup = CVErr(xlErrNA)
Else
'---------------
'-- Main loop --
'---------------
If Len(GroupValue) <> 0 Then
With rSearchRange.Offset(, GroupColOffset)
For Each rCur In rSearchRange.Offset(, GroupColOffset)
vCurValue = rCur.Value
If VarType(vCurValue) = vbString Then
bWanted = LCase$(CStr(vCurValue)) = LCase$(CStr(GroupValue))
Else
bWanted = Val(vCurValue) = Val(GroupValue)
End If
If bWanted Then
FuzzyVlookupMain LookupValue:=LookupValue, _
TableArray:=rCur.Offset(, GroupColOffset * -1), _
IndexNum:=IndexNum, _
NFPercent:=sngNFPercent, _
Rank:=iRankHigh, _
Algorithm:=Algorithm, _
AdditionalCols:=AdditionalCols, _
LookupColOffset:=LookupColOffset
End If
Next rCur
End With
Else
For Each rCur In rSearchRange
FuzzyVlookupMain LookupValue:=LookupValue, _
TableArray:=rCur, _
IndexNum:=IndexNum, _
NFPercent:=sngNFPercent, _
Rank:=iRankHigh, _
Algorithm:=Algorithm, _
AdditionalCols:=AdditionalCols, _
LookupColOffset:=LookupColOffset
Next rCur
End If
If (mudRankData(iaRank(1)).Percentage < sngNFPercent) _
And (mudRankData(iaRank(2)).Percentage < sngNFPercent) Then
'--------------------------------------
'-- Return '#N/A' if below NFPercent --
'--------------------------------------
FuzzyVLookup = CVErr(xlErrNA)
Else
sResult = ""
For iPtr2 = iaRank(1) To iaRank(2) Step iRankStep
If (mudRankData(iPtr2).Percentage >= sngaNFPercent(0)) _
And (mudRankData(iPtr2).Percentage <= sngaNFPercent(1)) Then
mlBestMatchPtr = mudRankData(iPtr2).Offset - TableArray.Cells(1, 1).Row + 1
If sResult <> "" Then sResult = sResult & sRankDelimiter
If IndexNum > 0 Then
'-----------------------------------
'-- Return column entry specified --
'-----------------------------------
sResult = sResult & CStr(TableArray.Cells(mlBestMatchPtr, IndexNum))
Else
'-----------------------
'-- Return offset row --
'-----------------------
sResult = sResult & CStr(mlBestMatchPtr)
End If
End If
Next iPtr2
FuzzyVLookup = sResult
End If
End If 'If rSearchRange Is Nothing Then
End Function
Private Sub FuzzyVlookupMain(ByVal LookupValue As String, _
ByVal TableArray As Range, _
ByVal IndexNum As Integer, _
Optional NFPercent As Single = 0.05, _
Optional Rank As Integer = 1, _
Optional Algorithm As Variant = 3, _
Optional AdditionalCols As Integer = 0, _
Optional LookupColOffset As Integer = 0)
Dim I As Integer
Dim intRankPtr As Integer
Dim intRankPtr1 As Integer
Dim strListString As String
Dim sngCurPercent As Single
Dim sngMinPercent As Single
Dim vCurValue As Variant
vCurValue = ""
For I = 0 To AdditionalCols
vCurValue = vCurValue & CStr(TableArray.Offset(0, I + LookupColOffset).Value)
Next I
If VarType(vCurValue) = vbString Then
strListString = LCase$(Application.Trim(vCurValue))
'------------------------------------------------
'-- Fuzzy match strings & get percentage match --
'------------------------------------------------
sngCurPercent = FuzzyPercent(String1:=LookupValue, _
String2:=strListString, _
Algorithm:=Algorithm, _
Normalised:=True)
If sngCurPercent >= NFPercent Then
'---------------------------
'-- Store in ranked array --
'---------------------------
For intRankPtr = 1 To Rank
If sngCurPercent > mudRankData(intRankPtr).Percentage Then
For intRankPtr1 = Rank To intRankPtr + 1 Step -1
With mudRankData(intRankPtr1)
.Offset = mudRankData(intRankPtr1 - 1).Offset
.Percentage = mudRankData(intRankPtr1 - 1).Percentage
End With
Next intRankPtr1
With mudRankData(intRankPtr)
.Offset = TableArray.Row
.Percentage = sngCurPercent
End With
Exit Sub
End If
Next intRankPtr
End If
End If
End Sub
Function Soundex(Surname As String) As String
' Developed by Richard J. Yanco
' This function follows the Soundex rules given at
' http://home.utah-inter.net/kinsearch/Soundex.html
Dim Result As String, c As String * 1
Dim Location As Integer
Surname = UCase(Surname)
If Surname = "" Then
Soundex = ""
Exit Function
End If
' First character must be a letter
If Asc(Left(Surname, 1)) < 65 Or Asc(Left(Surname, 1)) > 90 Then
Soundex = ""
Exit Function
Else
' St. is converted to Saint
If Left(Surname, 3) = "ST." Then
Surname = "SAINT" & Mid(Surname, 4)
End If
' Convert to Soundex: letters to their appropriate digit,
' A,E,I,O,U,Y ("slash letters") to slashes
' H,W, and everything else to zero-length string
Result = Left(Surname, 1)
For Location = 2 To Len(Surname)
Result = Result & SoundexCategory(Mid(Surname, Location, 1))
Next Location
' Remove double letters
Location = 2
Do While Location < Len(Result)
If Mid(Result, Location, 1) = Mid(Result, Location + 1, 1) Then
Result = Left(Result, Location) & Mid(Result, Location + 2)
Else
Location = Location + 1
End If
Loop
' If SoundexCategory of 1st letter equals 2nd character, remove 2nd character
If SoundexCategory(Left(Result, 1)) = Mid(Result, 2, 1) Then
Result = Left(Result, 1) & Mid(Result, 3)
End If
' Remove slashes
For Location = 2 To Len(Result)
If Mid(Result, Location, 1) = "/" Then
Result = Left(Result, Location - 1) & Mid(Result, Location + 1)
End If
Next
' Trim or pad with zeroes as necessary
Select Case Len(Result)
Case 4
Soundex = Result
Case Is < 4
Soundex = Result & String(4 - Len(Result), "0")
Case Is > 4
Soundex = Left(Result, 4)
End Select
End If
End Function
Private Function SoundexCategory(c) As String
' Returns a Soundex code for a letter
Select Case True
Case c Like "[AEIOUY]"
SoundexCategory = "/"
Case c Like "[BPFV]"
SoundexCategory = "1"
Case c Like "[CSKGJQXZ]"
SoundexCategory = "2"
Case c Like "[DT]"
SoundexCategory = "3"
Case c = "L"
SoundexCategory = "4"
Case c Like "[MN]"
SoundexCategory = "5"
Case c = "R"
SoundexCategory = "6"
Case Else 'This includes H and W, spaces, punctuation, etc.
SoundexCategory = ""
End Select
End Function
Private Function NormaliseStringAtoZ(ByVal String1 As String) As String
'---------------------------------------------------------
'-- Remove all but alpha chars and convert to lowercase --
'---------------------------------------------------------
Dim iPtr As Integer
Dim sChar As String
Dim sResult As String
sResult = ""
For iPtr = 1 To Len(String1)
sChar = LCase$(Mid$(String1, iPtr, 1))
If sChar <> UCase$(sChar) Then sResult = sResult & sChar
Next iPtr
NormaliseStringAtoZ = sResult
End Function
Function Metaphone1(ByVal String1 As String) As String
'-- Metaphone Basic Rules
'-- ** NOTE ** Depending on the order that they are obeyed, these rules can cancel each other out
'-- I have amended the order that the rules are obeyed as I feel appropriate, but uncertain that it is as the
'-- author intended.
'-- These are the rules as specified in Wikipedia entry:
'-- 1.***** Drop duplicate adjacent letters, except for C.
'-- 2.***** If the word begins with 'KN', 'GN', 'PN', 'AE', 'WR', drop the first letter.
'-- 3.***** Drop 'B' if after 'M' at the end of the word.
'-- 4.***** 'C' transforms to 'X' if followed by 'IA' or 'H' (unless in latter case, it is part of '-SCH-', in which case it transforms to 'K'). 'C' transforms to 'S' if followed by 'I', 'E', or 'Y'. Otherwise, 'C' transforms to 'K'.
'-- 5.***** 'D' transforms to 'J' if followed by 'GE', 'GY', or 'GI'. Otherwise, 'D' transforms to 'T'.
'-- 6.***** Drop 'G' if followed by 'H' and 'H' is not at the end or before a vowel. Drop 'G' if followed by 'N' or 'NED' and is at the end.
'-- 7.***** 'G' transforms to 'J' if before 'I', 'E', or 'Y', and it is not in 'GG'. Otherwise, 'G' transforms to 'K'.
'-- 8.***** Drop 'H' if after vowel and not before a vowel.
'-- 9.***** 'CK' transforms to 'K'.
'-- 10.*** 'PH' transforms to 'F'.
'-- 11.*** 'Q' transforms to 'K'.
'-- 12.*** 'S' transforms to 'X' if followed by 'H', 'IO', or 'IA'.
'-- 13.*** 'T' transforms to 'X' if followed by 'IA' or 'IO'. 'TH' transforms to '0'. Drop 'T' if followed by 'CH'.
'-- 14.*** 'V' transforms to 'F'.
'-- 15.*** 'WH' transforms to 'W' if at the beginning. Drop 'W' if not followed by a vowel.
'-- 16.*** 'X' transforms to 'S' if at the beginning. Otherwise, 'X' transforms to 'KS'.
'-- 17.*** Drop 'Y' if not followed by a vowel.
'-- 18.*** 'Z' transforms to 'S'.
'-- 19.*** Drop all vowels unless it is the beginning.
Dim iPtr As Integer
Dim iLen As Integer
Dim sString As String
Dim sResult As String
Dim sChar As String
Dim sLeft As String
Dim sRight As String
Dim sAtoZ As String
Dim vArray As Variant
Dim vCur As Variant
'-- Remove non alphabetics and convert to lowercase --
sString = NormaliseStringAtoZ(String1)
'-- 5.***** 'D' transforms to 'J' if followed by 'GE', 'GY', or 'GI'. Otherwise, 'D' transforms to 'T'.
sString = Replace(sString, "dge", "j")
sString = Replace(sString, "dgy", "j")
sString = Replace(sString, "dgi", "j")
sString = Replace(sString, "d", "t")
'-- 2.*If the word begins with 'KN', 'GN', 'PN', 'AE', 'WR', drop the first letter.
vArray = Array("kn", "gn", "pn", "ae", "wr")
For Each vCur In vArray
If Left$(sString, 2) = CStr(vCur) Then
sString = Right$(sString, Len(sString) - 1)
Exit For
End If
Next vCur
'-- 7.***** 'G' transforms to 'J' if before 'I', 'E', or 'Y', and it is not in 'GG'. Otherwise, 'G' transforms to 'K'.
iPtr = InStr(sString, "g")
iLen = Len(sString)
Do
If iPtr < 1 Or iPtr >= Len(sString) Then Exit Do
If Mid$(sString & " ", iPtr, 2) <> "gg" Then
If InStr("iey", Mid$(sString & " ", iPtr + 1, 1)) > 0 Then
Mid$(sString, iPtr, 1) = "j"
Else
Mid$(sString, iPtr, 1) = "k"
End If
End If
iPtr = InStr(iPtr + 1, sString, "g")
Loop
'-- 1. Drop duplicate adjacent letters, except for C.
sAtoZ = "abdefghijklmnopqrstuvwxyz"
For iPtr = 1 To Len(sAtoZ)
sChar = Mid$(sAtoZ, iPtr, 1)
sString = Replace(sString, sChar & sChar, sChar)
Next iPtr
'-- 3.***** Drop 'B' if after 'M' at the end of the word.
If Right$(sString, 2) = "mb" Then sString = Left$(sString, Len(sString) - 1)
'-- 9.***** 'CK' transforms to 'K'.
sString = Replace(sString, "ck", "k")
'-- 4.***** 'C' transforms to 'X' if followed by 'IA' or 'H' (unless in latter case, it is part of '-SCH-',
'-- in which case it transforms to 'K'). 'C' transforms to 'S' if followed by 'I', 'E', or 'Y'.
'-- Otherwise, 'C' transforms to 'K'.
sString = Replace(sString, "sch", "k")
sString = Replace(sString, "cia", "x")
sString = Replace(sString, "ch", "x")
sString = Replace(sString, "ci", "s")
sString = Replace(sString, "ce", "s")
sString = Replace(sString, "cy", "s")
sString = Replace(sString, "c", "k")
'-- 6.***** Drop 'G' if followed by 'H' and 'H' is not at the end or before a vowel.
'-- Drop 'G' if followed by 'N' or 'NED' and is at the end.
If Right$(sString, 4) = "gned" Then sString = Left$(sString, Len(sString) - 4) & "ned"
If Right$(sString, 2) = "gn" Then sString = Left$(sString, Len(sString) - 2) & "n"
iPtr = InStr(sString, "g")
Do
iLen = Len(sString)
If iPtr >= iLen Or iPtr < 1 Then Exit Do
If Mid$(sString, iPtr, 2) = "gh" Then
If InStr("aeiou", Mid$(sString, iPtr + 2)) < 1 Then
sLeft = Left$(sString, iPtr - 1)
sRight = Mid$(sString, iPtr + 1)
sString = sLeft & sRight
End If
End If
iPtr = InStr(iPtr + 1, sString, "g")
Loop
'-- 13.*** 'T' transforms to 'X' if followed by 'IA' or 'IO'. 'TH' transforms to '0'. Drop 'T' if followed by 'CH'.
sString = Replace(sString, "tio", "xio")
sString = Replace(sString, "tia", "xia")
sString = Replace(sString, "tch", "ch")
sString = Replace(sString, "th", "0")
'-- 8.***** Drop 'H' if after vowel and not before a vowel.
iPtr = InStr(sString, "h")
Do
iLen = Len(sString)
If iPtr < 1 Then Exit Do
If InStr("aeiou", Mid$(sString & " ", iPtr + 1, 1)) < 1 Then
If InStr("aeiou", Mid$(" " & sString, iPtr, 1)) > 0 Then
sLeft = Left$(sString, iPtr - 1)
sRight = Mid$(sString, iPtr + 1)
sString = sLeft & sRight
iPtr = iPtr - 1
End If
End If
iPtr = InStr(iPtr + 1, sString, "h")
Loop
'-- 10.*** 'PH' transforms to 'F'.
sString = Replace(sString, "ph", "f")
'-- 11.*** 'Q' transforms to 'K'.
sString = Replace(sString, "q", "k")
'-- 12.*** 'S' transforms to 'X' if followed by 'H', 'IO', or 'IA'.
sString = Replace(sString, "sio", "xio")
sString = Replace(sString, "sia", "xia")
sString = Replace(sString, "sh", "xh")
'-- 14.*** 'V' transforms to 'F'.
sString = Replace(sString, "v", "f")
'-- 15.*** 'WH' transforms to 'W' if at the beginning. Drop 'W' if not followed by a vowel.
If Left$(sString, 2) = "wh" Then sString = "w" & Mid$(sString, 3)
'-- 16.*** 'X' transforms to 'S' if at the beginning. Otherwise, 'X' transforms to 'KS'.
If Left$(sString, 1) = "x" Then sString = "s" & Mid$(sString, 2)
sString = Replace(sString, "x", "ks")
'-- 17.*** Drop 'Y' if not followed by a vowel.
iPtr = InStr(sString, "y")
Do
If iPtr < 1 Then Exit Do
If InStr("aeiou", Mid$(sString & " ", iPtr + 1, 1)) < 1 Then
sLeft = Left$(sString, iPtr - 1)
sRight = Mid$(sString, iPtr + 1)
sString = sLeft & sRight
iPtr = iPtr - 1
End If
iPtr = InStr(iPtr + 1, sString, "y")
Loop
'-- 18.*** 'Z' transforms to 'S'.
sString = Replace(sString, "z", "s")
'-- 19.*** Drop all vowels unless it is the beginning.
sResult = Left$(sString, 1)
For iPtr = 2 To Len(sString)
sChar = Mid$(sString, iPtr, 1)
If InStr("aeiou", sChar) < 1 Then sResult = sResult & sChar
Next iPtr
Metaphone1 = sResult
End Function
