Approximate Matching of strings?

[bombay69]

Hi Everyone,
Perhaps you can help me!?
I need to approximately match off different cells via a lookup eg.

cell 1 cell2 cell3 cell 4 cell 5 cell 6
123 john 1976 123 Jon 1976

I want excel to match of cell 1,2&3 with Cell 4,5&6 even though there is a difference in the string. Can you do something where if eg 10 characters match the contents of a cell a match is made in excel. Trying to match off cells but the entries differ slightly between the excel sheets i get. I saw a VB solution but how do i implement it? Would like something simpler if possible??

THANKS
::::::::::::::::::::::::::::::::::::::::::::::
VB SOLUTION BELOW:
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
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)

'----------------------------------------
'-- 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
intTotScore = intLen1 'initialise 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
intScore = intScore + 1 'Update current score
End If
Else
intPos = intStartPos
End If
Next intPtr
End If

'-----------------------------------------------------------
'-- If Algorithm = 2 or 3, Search for pairs, triplets etc. --
'-----------------------------------------------------------
If (Algorithm And 2) <> 0 Then
For intCurLen = 2 To intLen1
strWork = String2 'Get a copy of String2
intTo = intLen1 - intCurLen + 1
intTotScore = intTotScore + 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
intScore = intScore + 1 'Update current score
End If
Next intPtr
Next intCurLen
End If

FuzzyPercent = intScore / intTotScore

End Function

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) 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: **
'** 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 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 udRankData() As RankInfo

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

'---------------
'-- Main loop --
'---------------
intPtr = 1
Do While VarType(TableArray.Cells(intPtr, 1)) <> vbEmpty
If VarType(TableArray.Cells(intPtr, 1)) = vbString Then
strListString = LCase$(Application.Trim _
(TableArray.Cells(intPtr, 1)))

'------------------------------------------------
'-- 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 = intPtr
.Percentage = sngCurPercent
End With
Exit For
End If
Next intRankPtr
End If

End If
intPtr = intPtr + 1
Loop

If udRankData(Rank).Percentage < sngMinPercent Then
'--------------------------------------
'-- Return '#N/A' if below NFPercent --
'--------------------------------------
FuzzyVLookup = CVErr(xlErrNA)
Else
intBestMatchPtr = udRankData(Rank).Offset
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 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 udRankData() As RankInfo
'--------------------------------------------------------------
'-- 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)

'---------------
'-- Main loop --
'---------------
intPtr = 1
Do While VarType(TableArray.Cells(1, intPtr)) <> vbEmpty
If VarType(TableArray.Cells(1, intPtr)) = vbString Then
strListString = LCase$(Application.Trim _
(TableArray.Cells(1, intPtr)))

'------------------------------------------------
'-- 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 = intPtr
.Percentage = sngCurPercent
End With
Exit For
End If
Next intRankPtr
End If

End If
intPtr = intPtr + 1
Loop

If udRankData(Rank).Percentage < sngMinPercent Then
'--------------------------------------
'-- Return '#N/A' if below NFPercent --
'--------------------------------------
FuzzyHLookup = CVErr(xlErrNA)
Else
intBestMatchPtr = udRankData(Rank).Offset
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

 

[al_b_cnu]

HI,

This link gives an example & the latest version of the code
http://www.mrexcel.com/board2/viewtopic.php?t=109237

To install,

1) Copy the code from the above link
2) [Alt-F11]
3) Insert / Module
4) Paste the code into the window


The code, as supplied, only does a compare on single cells, maybe you could concatenate the cells in your sheet?

HTH

Alan

 

[al_b_cnu]

Hi,

This modified code may do what you want:

Option Explicit
Type RankInfo
    Offset As Integer
    Percentage As Single
End Type
Sub Auto_Open()
'There are 10 categories
'1 = finance
'2 = date & time
'3 = math & trig
'4 = statistics
'5 = matrices
'6 = database
'7 = text functions
'8 = logic
'9 = info
'10 = User defined

Application.MacroOptions _
    Macro:="FuzzyPercent", _
    Description:="Return percentage match between two strings", _
    Category:=10
Application.MacroOptions _
    Macro:="FuzzyVLookup", _
    Description:="Return best match for string from column range", _
    Category:=10
Application.MacroOptions _
    Macro:="FuzzyHLookup", _
    Description:="Return best match for string from row range", _
    Category:=10
End Sub
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
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)

'----------------------------------------
'-- 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
    intTotScore = intLen1                   'initialise 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
                intScore = intScore + 1          'Update current score
            End If
        Else
            intPos = intStartPos
        End If
    Next intPtr
End If

'-----------------------------------------------------------
'-- If Algorithm = 2 or 3, Search for pairs, triplets etc. --
'-----------------------------------------------------------
If (Algorithm And 2) <> 0 Then
    For intCurLen = 2 To intLen1
        strWork = String2                          'Get a copy of String2
        intTo = intLen1 - intCurLen + 1
        intTotScore = intTotScore + 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
                intScore = intScore + 1     'Update current score
            End If
        Next intPtr
    Next intCurLen
End If

FuzzyPercent = intScore / intTotScore

End Function

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

Parameters to FuzzyVLookup are:
1) Lookup value, similar to VLookup, in your case, this would be a concatenation of the cells 1, 2 & 3, e.g. A1&B1&C1

2) Range to be searched (similar to VLookup)
If column E contained the first part of the lookup value, F the 2nd & G the 3rd and H contained the value to be returned, you would use, e.g. E:H for this parameter

3) EITHER Column required to be returned, similar to VLookup, e.g. 4 if the 4th column in the range specified was to be returned,
OR zero indivcating that the row number of the best match is to be returned.

4) 'Not Found' Percentage value. If the best match is lower than this percentage value, #N/A will be returned. Suggested value: 70%.

5) Rank. Set to 1

6) Algorithm, 1 = 'forward scan only, 2 = match pairs then triplets then quads etc, 3 = hybrid. Suggest 3 initially.

7) Additional Cols - set to 2 for 3 columns to be concatenated before compare with lookup value

 

[al_b_cnu]

Here's an Example via HTMLMaker:

FuzzyVLookup V3 Example.xls
	A	B	C	D	E	F	G	H	I	J	K
1	Lookup Value	Value 1	Value 2	Value 3	Return Value	% Match 1	% Match 2	% Match 3	Vlookup 1	Vlookup 2	Vlookup 3
2	George	George		Bush	a	90.91%	50.00%	65.52%	a	f	a
3	W	Gorge	W	Bush	b	18.18%	44.44%	34.48%
4	Bush	George		Clooney	c	54.55%	44.44%	48.28%
5		Bird	in	bush	d	0.00%	5.56%	3.45%	2	7	2
6		Mr	Tony	Blair	e	9.09%	0.00%	3.45%
7		Bush	George	W	f	18.18%	55.56%	41.38%
Sheet1

A2:A4 is the lookup value
Columns B:E is the lookup table
Columns F:H contain the % match of A2:A4 to each individual table entry using algorithms 1, 2 & 3 respectively

I2 contains the algorithm 1 formula =fuzzyvlookup($A$2&$A$3&$A$4,$B:$E,4,0.5,1,1,2)
J2 contains the algorithm 2 formula =fuzzyvlookup($A$2&$A$3&$A$4,$B:$E,4,0.5,1,2,2)
K22 contains the algorithm 3 formula =fuzzyvlookup($A$2&$A$3&$A$4,$B:$E,4,0.5,1,3,2)

All 3 above return the value in the 4th column of the table.

I5 contains the algorithm 1 formula =fuzzyvlookup($A$2&$A$3&$A$4,$B:$E,0,0.5,1,1,2)

J5 contains the algorithm 2 formula =fuzzyvlookup($A$2&$A$3&$A$4,$B:$E,0,0.5,1,2,2)

K5 contains the algorithm 3 formula =fuzzyvlookup($A$2&$A$3&$A$4,$B:$E,0,0.5,1,3,2)

All 3 above return the row number of the best match