Fuzzy Matching - new version plus explanation

al_b_cnu

Well-known Member
Joined
Jul 18, 2003
Messages
4,546
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 ...
 
Hi NPC,

Two methods sping to mind,

Fists, use FuzzyvLookup with algorithm = 1 which is described in the comments as follows:
Code:
'** 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.

Second if you look on page 22 of this (rather long) thread you'll see a functionm "GetLevenshteinPercentMatch" which is a VBA implementation of Levenshtein's algorithm. Note however, that whilst it may be more accurate (if such a description can be used in fuzzy matching), in tests I found it to be rather slower than fuzzyVLookup algorithm 1 or 2.
 
Upvote 0

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Thanks for the advice! I'd tried algorithm 2 and 3, but I'll give #1 a whirl and also check out the GetLevenshteinPercentMatch if I'm still desperate enough to give up speed for a closer match. I'll let you know how it goes--cheers!
 
Upvote 0
Just a minor update as promised, I tried algorithm 1 and it looks like we still need something a little different. Our situation may be a bit different from many others using FuzzyVLookup since we are not trying to find duplicates of the same information, per se, but rather trying to create a method to check new terms against an existing glossary to make sure they aren't too similar to an existing terms. We're looking at doing a combination of Soundex and Levenshtein distance to accomplish that now, but thanks again for your suggestion! I'm glad we tried everything with FuzzyVLookup first, to see what it could do for us and what functions we still needed!
 
Upvote 0
Hi NPC, thanks for the update.

I assume you're using the FuzzyvLookup harness with Levenstein algorithm by adapting the function "GetLevenshteinPercentMatch" on page 22 of this thread?
 
Upvote 0
I've been able to use the GetLevenshteinPrecentMatch to compare two cells (like =LevenshteinDistance(D14,E14)) but are you asking about a way of using the Levenshtein Distance within the FuzzyVLookup framework? If so, I'm afraid I don't know how to implement that. I am honestly only about 2 steps beyond a novice when it comes to all this.

If there is such a way, it would be a great step for us if we could compare a list (say all terms in column D) with new proposed term (a particular cell in column E) and return all matches with a Levenshtein Distance of less than 5, for example. Is there a way to do this with FuzzyVLookup?

Sorry for the ignorant questions, but thank you for continuing to follow up with me!
 
Upvote 0
So, it's been a while since the last post in this thread, but maybe you can still help me.

I've been unable to get this code to work in OpenOffice. Is this expected?

Also, Alt-F11 does not work in Excel 2010, at least in Starter Edition. Is this expected?

Can I make this code work with any of the above programs?

Thanks!
 
Upvote 0
Hi Morganj2003, welcome to the board.

I'm afraid that Open Office VB is a different dialect to VBA (Which is different to VB,net), so I would be most surprised if you reported that it did work.

More bad news - Looking at the description of starter 2010, it does not mention that macros are not available specifically, but I strongly suspect so.
 
Upvote 0
Hi NPC,

Have been a while as I decided to update the documentation whilst I was at it, which took most of the time :-?

Ok, this is the new code in which Algorithm 4 now calls the the GetLevenshteinPercentMatch function:
Code:
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.
'**      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

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 Integer = 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:=True) >= 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 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 sngScore As Single
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)

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

'--------------------------------------------------------
'-- If Algorithm = 1 or 3, Search for single characters --
'--------------------------------------------------------
If (Algorithm 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 (Algorithm 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 (Algorithm 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) = Minimum(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 Integer = 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 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 Integer = 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

Continued ...
 
Upvote 0
... Continued

Here's an example, note the use of the extended format of the Rank parameter in cells N3, O3:

Excel 2003
ABCDEFGHIJKLMNO
1Rank
2Lookup TableLookup ValueRank:123456789101 1010, 1
3AlphaETAResult:EtaBetaZetaDeltaThetaIota#N/A#N/A#N/A#N/AEta Beta Zeta Delta Theta IotaIota, Theta, Delta, Zeta, Beta, Eta
4Beta% match:100%75%75%60%60%50%
5Gamma
6Delta
7Epsilon
8Zeta
9Eta
10Theta
11Iota
12Kappa
13Lambda
14Mu
15Nu
16omicron
Sheet1
Cell Formulas
RangeFormula
D3=fuzzyvlookup($B3,$A:$A,1,50,D$2,4)
D4=FuzzyPercent($B$3,D3,4)
E3=fuzzyvlookup($B3,$A:$A,1,50,E$2,4)
E4=FuzzyPercent($B$3,E3,4)
F3=fuzzyvlookup($B3,$A:$A,1,50,F$2,4)
F4=FuzzyPercent($B$3,F3,4)
G3=fuzzyvlookup($B3,$A:$A,1,50,G$2,4)
G4=FuzzyPercent($B$3,G3,4)
H3=fuzzyvlookup($B3,$A:$A,1,50,H$2,4)
H4=FuzzyPercent($B$3,H3,4)
I3=fuzzyvlookup($B3,$A:$A,1,50,I$2,4)
I4=FuzzyPercent($B$3,I3,4)
J3=fuzzyvlookup($B3,$A:$A,1,50,J$2,4)
K3=fuzzyvlookup($B3,$A:$A,1,50,K$2,4)
L3=fuzzyvlookup($B3,$A:$A,1,50,L$2,4)
M3=fuzzyvlookup($B3,$A:$A,1,50,M$2,4)
N3=fuzzyvlookup($B3,$A:$A,1,50%,N$2,4)
O3=fuzzyvlookup($B3,$A:$A,1,50,O$2,4)


Note that you still have to specify a NFPercent instead of Levenshtein distance, but the functions are available to be called independently.
 
Upvote 0
Brilliant! That is amazing and works exactly as we were hoping for! Thank you so much for implementing this; it is giving great results! The only thing we might still try to do is implement a search that outputs a similar list based on similarity between Soundex codes or maybe Metaphone. Have you ever by chance been tempted to add either function to your FuzzyVLookup? ;)

If not, we'll cobble something together somehow, but just thought I'd throw it out there in case you might want another challenge to wrestle. If you don't have time or the inclination, what you have already done is going to be a lifesaver for us, so thanks again!
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,933
Messages
6,175,479
Members
452,647
Latest member
MatthewBiersay

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
Back
Top