# Fuzzy Matching - new version plus explanation

#### al_b_cnu

##### Well-known Member
It has been a while since I originally posted my Fuzzy matching UDF’s on the board, and several variants have appeared subsequently.

I thought it time to ‘put the record straight’ & post a definitive version which contains slightly more efficient code, and better matching algorithms, so here it is.

Firstly, I must state that the Fuzzy matching algorithms are very CPU hungry, and should be used sparingly. If for instance you require to lookup a match for a string which starts with, contains or ends with a specified value, this can be performed far more efficiently using the MATCH function:
Fuzzy Examples.xls
ABCDE
1Starts WithEndsContains
2BilljelenBill
3Mr Bill Jelen433
4Bill Jelen
5Joe Bloggs
6Fred Smith
MATCH Example

... Continued ...

### Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

#### al_b_cnu

##### Well-known Member
That said, there are times when you have to send for the ‘big boys’.
Code:
``````Option Explicit
Type RankInfo
Offset As Integer
Percentage As Single
End Type

Function FuzzyPercent(ByVal String1 As String, _
ByVal String2 As String, _
Optional Algorithm As Integer = 3, _
Optional Normalised As Boolean = False) As Single
'*************************************
'** Return a % match on two strings **
'*************************************
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 strWork As String

'-------------------------------------------------------
'-- If strings havent been normalised, normalise them --
'-------------------------------------------------------
If Normalised = False Then
String1 = LCase\$(Application.Trim(String1))
String2 = LCase\$(Application.Trim(String2))
End If

'----------------------------------------------
'-- Give 100% match if strings exactly equal --
'----------------------------------------------
If String1 = String2 Then
FuzzyPercent = 1
Exit Function
End If

intLen1 = Len(String1)
intLen2 = Len(String2)

'----------------------------------------
'-- 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

'--------------------------------------------------------
'-- If Algorithm = 1 or 3, Search for single characters --
'--------------------------------------------------------
If (Algorithm And 1)<> 0 Then
FuzzyAlg1 String1, String2, intScore, intTotScore
If intLen1< intLen2 Then FuzzyAlg1 String2, String1, intScore, intTotScore
End If

'-----------------------------------------------------------
'-- If Algorithm = 2 or 3, Search for pairs, triplets etc. --
'-----------------------------------------------------------
If (Algorithm And 2)<> 0 Then
FuzzyAlg2 String1, String2, intScore, intTotScore
If intLen1< intLen2 Then FuzzyAlg2 String2, String1, intScore, intTotScore
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 = 2 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

Function FuzzyVLookup(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 Integer = 3, _
Optional AdditionalCols As Integer = 0) As Variant
'********************************************************************************
'** Function to Fuzzy match LookupValue with entries in                        **
'** column 1 of table specified by TableArray.                                 **
'** TableArray must specify the top left cell of the range to be searched      **
'** The function stops scanning the table when an empty cell in column 1       **
'** is found.                                                                  **
'** For each entry in column 1 of the table, FuzzyPercent is called to match   **
'** LookupValue with the Table entry.                                          **
'** 'Rank' is an optional parameter which may take any value > 0               **
'**        (default 1) and causes the function to return the 'nth' best        **
'**         match (where 'n' is defined by 'Rank' parameter)                   **
'** If the 'Rank' match percentage< NFPercent (Default 5%), #N/A is returned. **
'** IndexNum is 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 offset row (starting at 1) is returned.   **
'**                 This value can be used directly in the 'Index' function.   **
'**                                                                            **
'** Algorithm 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.                      **
'********************************************************************************
Dim R As Range

Dim strListString As String
Dim strWork As String

Dim sngMinPercent As Single
Dim sngWork As Single
Dim sngCurPercent  As Single
Dim intBestMatchPtr As Integer
Dim intRankPtr As Integer
Dim intRankPtr1 As Integer
Dim I As Integer

Dim lEndRow As Long

Dim udRankData() As RankInfo

Dim vCurValue As Variant

'--------------------------------------------------------------
'--    Validation                                            --
'--------------------------------------------------------------

LookupValue = LCase\$(Application.Trim(LookupValue))

If IsMissing(NFPercent) Then
sngMinPercent = 0.05
Else
If (NFPercent<= 0) Or (NFPercent > 1) Then
FuzzyVLookup = "*** 'NFPercent' must be a percentage > zero ***"
Exit Function
End If
sngMinPercent = NFPercent
End If

If Rank< 1 Then
FuzzyVLookup = "*** 'Rank' must be an integer > 0 ***"
Exit Function
End If

ReDim udRankData(1 To Rank)

lEndRow = TableArray.Rows.Count
If VarType(TableArray.Cells(lEndRow, 1).Value) = vbEmpty Then
lEndRow = TableArray.Cells(lEndRow, 1).End(xlUp).Row
End If

'---------------
'-- Main loop --
'---------------
For Each R In Range(TableArray.Cells(1, 1), TableArray.Cells(lEndRow, 1))
vCurValue = ""
For I = 0 To AdditionalCols
vCurValue = vCurValue & R.Offset(0, I).Text
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 >= sngMinPercent Then
'---------------------------
'-- Store in ranked array --
'---------------------------
For intRankPtr = 1 To Rank
If sngCurPercent > udRankData(intRankPtr).Percentage Then
For intRankPtr1 = Rank To intRankPtr + 1 Step -1
With udRankData(intRankPtr1)
.Offset = udRankData(intRankPtr1 - 1).Offset
.Percentage = udRankData(intRankPtr1 - 1).Percentage
End With
Next intRankPtr1
With udRankData(intRankPtr)
.Offset = R.Row
.Percentage = sngCurPercent
End With
Exit For
End If
Next intRankPtr
End If

End If
Next R

If udRankData(Rank).Percentage< sngMinPercent Then
'--------------------------------------
'-- Return '#N/A' if below NFPercent --
'--------------------------------------
FuzzyVLookup = CVErr(xlErrNA)
Else
intBestMatchPtr = udRankData(Rank).Offset - TableArray.Cells(1, 1).Row + 1
If IndexNum > 0 Then
'-----------------------------------
'-- Return column entry specified --
'-----------------------------------
FuzzyVLookup = TableArray.Cells(intBestMatchPtr, IndexNum)
Else
'-----------------------
'-- Return offset row --
'-----------------------
FuzzyVLookup = intBestMatchPtr
End If
End If
End Function
Function FuzzyHLookup(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 Integer = 3) As Variant
'********************************************************************************
'** Function to Fuzzy match LookupValue with entries in                        **
'** row 1 of table specified by TableArray.                                    **
'** TableArray must specify the top left cell of the range to be searched      **
'** The function stops scanning the table when an empty cell in row 1          **
'** is found.                                                                  **
'** For each entry in row 1 of the table, FuzzyPercent is called to match      **
'** LookupValue with the Table entry.                                          **
'** 'Rank' is an optional parameter which may take any value > 0               **
'**        (default 1) and causes the function to return the 'nth' best        **
'**         match (where 'n' is defined by 'Rank' parameter)                   **
'** If the 'Rank' match percentage< NFPercent (Default 5%), #N/A is returned. **
'** IndexNum is the row 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 row entry indicated by IndexNum is        **
'**                 returned.                                                  **
'** if IndexNum = 0 and the 'Rank' percentage match is >= NFPercent            **
'**                 (Default 5%) the offset col (starting at 0) is returned.   **
'**                 This value can be used directly in the 'OffSet' function.  **
'**                                                                            **
'** Algorithm can take one of the following values:                            **
'** Algorithm = 1:                                                             **
'**     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:                                                             **
'**     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.                      **
'********************************************************************************
Dim R As Range

Dim strListString As String
Dim strWork As String

Dim sngMinPercent As Single
Dim sngWork As Single
Dim sngCurPercent  As Single

Dim intBestMatchPtr As Integer
Dim intPtr As Integer
Dim intRankPtr As Integer
Dim intRankPtr1 As Integer

Dim iEndCol As Integer

Dim udRankData() As RankInfo

Dim vCurValue As Variant
'--------------------------------------------------------------
'--    Validation                                            --
'--------------------------------------------------------------
LookupValue = LCase\$(Application.Trim(LookupValue))

If IsMissing(NFPercent) Then
sngMinPercent = 0.05
Else
If (NFPercent<= 0) Or (NFPercent > 1) Then
FuzzyHLookup = "*** 'NFPercent' must be a percentage > zero ***"
Exit Function
End If
sngMinPercent = NFPercent
End If

If Rank< 1 Then
FuzzyHLookup = "*** 'Rank' must be an integer > 0 ***"
Exit Function
End If

ReDim udRankData(1 To Rank)
'**************************
iEndCol = TableArray.Columns.Count
If VarType(TableArray.Cells(1, iEndCol).Value) = vbEmpty Then
iEndCol = TableArray.Cells(1, iEndCol).End(xlToLeft).Column
End If

'---------------
'-- Main loop --
'---------------
For Each R In Range(TableArray.Cells(1, 1), TableArray.Cells(1, iEndCol))
vCurValue = R.Value
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 >= sngMinPercent Then
'---------------------------
'-- Store in ranked array --
'---------------------------
For intRankPtr = 1 To Rank
If sngCurPercent > udRankData(intRankPtr).Percentage Then
For intRankPtr1 = Rank To intRankPtr + 1 Step -1
With udRankData(intRankPtr1)
.Offset = udRankData(intRankPtr1 - 1).Offset
.Percentage = udRankData(intRankPtr1 - 1).Percentage
End With
Next intRankPtr1
With udRankData(intRankPtr)
.Offset = R.Column
.Percentage = sngCurPercent
End With
Exit For
End If
Next intRankPtr
End If

End If
Next R

If udRankData(Rank).Percentage< sngMinPercent Then
'--------------------------------------
'-- Return '#N/A' if below NFPercent --
'--------------------------------------
FuzzyHLookup = CVErr(xlErrNA)
Else
intBestMatchPtr = udRankData(Rank).Offset - TableArray.Cells(1, 1).Column + 1
If IndexNum > 0 Then
'-----------------------------------
'-- Return row entry specified --
'-----------------------------------
FuzzyHLookup = TableArray.Cells(IndexNum, intBestMatchPtr)
Else
'-----------------------
'-- Return offset col --
'-----------------------
FuzzyHLookup = intBestMatchPtr
End If
End If
End Function``````

Three Fuzzy matching UDF’s are available, FUZZYVLOOKUP, FUZZYHLOOKUP and FUZZYPERCENT.

FUZZYVLOOKUP is the ‘fuzzy’ equivalent of ‘VLOOKUP and has the following parameters:

Lookupvalue
The value to search in the first column of the table array

Tablearray
One or more columns of data. Use a reference to a range or a range name. The values in the first column of table array are the values searched by lookup value.

Indexnum
The column number in the table array from which the matching value must be returned. An index num of 1 returns the value in the first column in the table array; an index num of 2 returns the value in the second column in the table array, and so on. If index num is zero, the relative row number in the table array is returned.

NFpercent
The Percentage value below which matching strings are deemed as not found. If no strings in the lookup table equal or exceed this matching percentage, #N/A is returned.
The higher the percentage specified, the higher the confidence level in the returned result.
Default: 5%

Rank
An optional parameter which may take any value > 0 and causes the function to return the specified ranking best match.
Default: 1

Algorithm
Defines the algorithm to be used for matching strings. Valid values are 1, 2 or 3:
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.
Default: 3

Additionalcols
Defines the number of subsequent columns after the first within the table array to be concatenated with the first column prior to matching.
Default: 0

FUZZYHLOOKUP is the ‘fuzzy’ equivalent of ‘HLOOKUP and has the following parameters, descriptions as for FuzzyVLookup:
LookupValue
TableArray
IndexNum
NFPercent
Rank
Algorithm

FUZZYPERCENT is at the heart of FuzzyVLookup and FuzzyHLookup, and returns the percentage match of the two strings supplied. This UDF can be called independently. It has the following parameters:

String1
The first string to be matched. FuzzyVLookup will pass the lookup value supplied (but normalised) as this parameter.

String2
The second string to be matched. FuzzyVLookup will pass each of the lookup table strings supplied (but normalised) as this parameter.

Algorithm
Algorithm to be used. See FuzzyVLookup for further details.
Default: 3

Normalised
Boolean value indicating whether the two supplied strings have been normalised. Normalised strings have had leading, trailing and multiple internal spaces removed, and have been converted to lowercase.
Default: False

EXAMPLES.

In the following example sheet,
Column A is the lookup table
Column B contain lookup values
Column C contains FuzzyVLookup formulae using algorithm 1
Column D contains FuzzyVLookup formulae using algorithm 2
Column E contains FuzzyVLookup formulae using algorithm 3.
Column F contains the FuzzyPercent result of column B versus column C using algorithm 1
Column G contains the FuzzyPercent result of column B versus column D using algorithm 2
Column H contains the FuzzyPercent result of column B versus column E using algorithm 3
Fuzzy Examples.xls
ABCDEFGH
1FuzzyVLookup - AlgorithmFuzzyPercent - Algorithm
2123123
3Paul McCartneyGeorge BushGeorge HarrisGeorge HarrisGeorge Harris66.67%42.86%51.52%
4George HarrisGorge hrsGeorge HarrisGeorge HarrisGeorge Harris54.55%21.05%33.33%
5Ringo StarrStarr,RingoChuck NorrisRingo StarrRingo Starr17.39%44.44%31.03%
6John LennonBush, GeorgeBruce LeeGeorge HarrisGeorge Harris25.00%31.91%26.39%
7Tony Blair
8George Clooney
9Chuck Norris
10Claude Van Damme
11Bruce Lee
Fuzzy Match Examples

formula in C3 and copied down and across to E6 is =fuzzyvlookup(\$B3,\$A:\$A,1,,,C\$2)
Formula in F3 and copied down and across to H6 is =fuzzypercent(\$B3,C3,F\$2)

#### ROYW1000

##### New Member
Fuzzy Lookup

Hi

I have copied the example data into an exel sheet and also copied the script but not sure how I get it work can anyone help.

So far I have really just got the excel data in the sheet and not sure if to do it as a macro or add as VB and how to go about it.

I did have a quick play but it just does nothing.

Thanks

Roy

#### al_b_cnu

##### Well-known Member
Hi,

Try:
1) Alt-F11
2) Insert / Module
3) Paste above code into code window

and you're now set to go!

using FUZZYVLOOKUP is similar to VLOOKUP.

#### ROYW1000

##### New Member

ADVERTISEMENT

Thank you that is great.

Roy

#### raceonusa

##### Board Regular
Hi I inserted the text with ALT F11, but it dosen't let me run the script.

#### GlennUK

##### Well-known Member

ADVERTISEMENT

In what way did you try to run the script? What happened when you tried to run the script ( what do you mean by "it doesn't let me" )?

#### raceonusa

##### Board Regular
Running the script.. Here's what I did, I opened the developer tab, and entered visual basic in QB 2007, then pasted all the code from the post. It looks like it was formatted ok, and I didn't get any errors, then I hit the (Play) button, but nothing happened, it didn't look like anything happened at least. Am I supposed to do this a different way? or maybe I am supposed to have new macros that I can run now under the macro button?

Thanks, Im a total noob.

#### raceonusa

##### Board Regular
Cannot execute module.

ok , after pasting in a new module in a macro enabled xlsm file in visual basic, I saved it and tried to run the script.. But there is no scipt to run.

I click on the green (play) button in visual basic, and the "Macros" window pops up, with no macros to choose from.

I tried this on another computer with excel 2007 , same problem..

Is there a chunk of that code that makes it incompatible with excel 2007?

I've gotten other macros to work from this forum. So unless there is a different way to save the module, or the code is proprietary for pre 2007 version, I'm stuck.

Anyone get it to work in 2007? #### Joe Was

##### MrExcel MVP
The code is not Normal Visual Basic!

It is Excel Visual Basic for Applications (Excel VBA)

It must be stored in a Standard code module, like: Module1, as is!

Alt + F11
Toolbar: Insert - Module
Paste code in the Editor window for that module!

Click the top-most-Right Close "X" to return to the sheet.

Replies
3
Views
789
Replies
0
Views
2K
Replies
3
Views
391
Replies
12
Views
896
Replies
4
Views
4K

Threads
1,126,957
Messages
5,621,822
Members
415,859
Latest member
Vain

### Share this page ### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

### Which adblocker are you using?    ### Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option. Go back

### Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com". Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button. Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button. Go back