Fuzzy Matching - new version plus explanation

al_b_cnu · Mar 27, 2006

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

A

B

C

D

E

1

Starts With

Ends

Contains

2

Bill

jelen

Bill

3

Mr Bill Jelen

4

3

4

Bill Jelen

5

Joe Bloggs

6

Fred Smith

MATCH Example

... Continued ...

al_b_cnu · Apr 14, 2024

Hi Greg,
Yes it seems that GetOpenFilename gives problems with Mac/OS.

Try the following, but not sure what is returned by GetOpenFileName if you cancel...

VBA Code:

Option Explicit

Type Params
    GroupHeading As String
    MatchHeading As String
    MatchesCount As Long
    MinPercent As Single
    Algorithm As Single
    DBQuantity As String
    DBBarcode As String
    ShowTitle As Boolean
    ShowQty As Boolean
End Type
Dim mudtParameters As Params

Type BrandBounds
    BrandName As String
    BrandLB As Long
    BrandUB As Long
End Type

Dim mcolBrandbounds As Collection

Type DatabaseData
    Brand As String
    Title As String
    Qty As String
    BarCode As String
End Type
Dim mudtDatabase() As DatabaseData

Type BarCodeMatches
    BarCode As String
    BrandPercent As Single
    MatchText As String
    Qty As String
End Type

Sub click_GetBarcodes()

Dim lUB As Long
Dim lLastUB  As Long
Dim lRow As Long

Dim saCurName() As String
Dim sCurTerminalName As String
Dim sPrevBrand As String
Dim sCurBrand As String

Dim vCurFilename As Variant
Dim vResellerFiles As Variant
Dim vaDatabase As Variant
Dim vaBrandLimits As Variant
Dim vaDicBrandItem As Variant
Dim vaBrandBounds As Variant

Dim udtBrandBound As BrandBounds

Dim WBcur As Workbook
Dim wbResults As Workbook

Dim wsDB As Worksheet
Dim wsCur As Worksheet

'MsgBox Application.OperatingSystem

mudtParameters = GetParameters()

Application.DisplayAlerts = False

'*********************************
'**Get database data into array **
'*********************************
Set wsDB = ThisWorkbook.Sheets("Database")
With wsDB.UsedRange
    vaDatabase = wsDB.Range("A1").Resize(.Rows.Count, .Columns.Count).Value
End With

'*************************************************************************************
'** Set up Brands bounds collection                                              **
'** Note that the database entries MUST be sorted into ascending brand sequence!    **
'*************************************************************************************
Set mcolBrandbounds = New Collection
lUB = 0
sPrevBrand = ""
ReDim vaBrandBounds(1 To 3)
For lRow = 2 To UBound(vaDatabase, 1)
    sCurBrand = NormaliseName(vaDatabase(lRow, 1))
    If sCurBrand <> "" Then
        If sCurBrand < sPrevBrand Then
            MsgBox prompt:="Database file MUST be sorted into ascending Brand sequence", _
                    Buttons:=vbOKOnly + vbCritical, _
                    Title:="Database Data Error"
            Set mcolBrandbounds = Nothing
            Exit Sub

        ElseIf sCurBrand = sPrevBrand Then
            '** Update End row for current brand
            vaBrandBounds(3) = lRow
        Else
            '** Here if new brand entry row encountered **
            If sPrevBrand <> "" Then
                On Error Resume Next
                mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds
                On Error GoTo 0
            End If
            vaBrandBounds(1) = sCurBrand
            vaBrandBounds(2) = lRow
            vaBrandBounds(3) = lRow
            
            sPrevBrand = sCurBrand
            
        End If
    End If
Next lRow
On Error Resume Next
mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds        '** Write final entry **
On Error GoTo 0

'**************************************************
'** Store database in the udt array mudtDatabase **
'**************************************************
Call PopulateDatabaseEntries(DBArray:=vaDatabase)

'***********************************
'** Get input reseller file names **
'***********************************
If InStr(1, Application.OperatingSystem, "Windows") = 0 Then
    vResellerFiles = Application.GetOpenFilename(Title:="Please select Reseller Excel file")
Else
    vResellerFiles = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", _
                                                Title:="Please select Reseller Excel file(s)", _
                                                MultiSelect:=True)
    If IsArray(vResellerFiles) = False Then Exit Sub
End If

'****************************
'** Create output workbook **
'****************************
Set wbResults = Nothing
On Error Resume Next
Set wbResults = Workbooks.Add
On Error GoTo 0
If wbResults Is Nothing Then
    If Err.Number > 0 Then
        MsgBox prompt:=Err.Description, _
                Buttons:=vbOKOnly + vbCritical, _
                Title:="Cannot create Results Workbook"
        
    End If
    Exit Sub
End If

'******************************
'** Process Reseller file(s) **
'******************************
If IsArray(vResellerFiles) Then
    For Each vCurFilename In vResellerFiles
        
        Call ProcessInputFile(DBData:=vaDatabase, _
                              InputFileName:=vCurFilename, _
                              ResultsWB:=wbResults)
        
    Next vCurFilename
Else
        Call ProcessInputFile(DBData:=vaDatabase, _
                          InputFileName:=vResellerFiles, _
                          ResultsWB:=wbResults)
End If

On Error Resume Next
wbResults.Sheets(1).Delete
Set mcolBrandbounds = Nothing
On Error GoTo 0

Application.StatusBar = False

End Sub

Private Sub PopulateDatabaseEntries(ByVal DBArray As Variant)
'************************************
'** Create entries in mudtDataBase **
'************************************
Dim lRow As Long
Dim lCol As Long
Dim lColBrand As Long
Dim lColTitle As Long
Dim lColQty As Long
Dim lColBarCode As Long
Dim lEntriesPtr As Long

Dim sCurHeading As String

For lCol = 1 To UBound(DBArray, 2)
    sCurHeading = NormaliseName(CStr(DBArray(1, lCol)))
    Select Case sCurHeading
        Case NormaliseName(mudtParameters.GroupHeading)
            lColBrand = lCol
        Case NormaliseName(mudtParameters.MatchHeading)
            lColTitle = lCol
        Case NormaliseName(mudtParameters.DBQuantity)
            lColQty = lCol
        Case NormaliseName(mudtParameters.DBBarcode)
            lColBarCode = lCol
    End Select
Next lCol

ReDim mudtDatabase(1 To 1)
lEntriesPtr = 1
mudtDatabase(1).Brand = ""
On Error Resume Next
For lRow = 2 To UBound(DBArray, 1)
    If Trim$(DBArray(lRow, lColBrand)) <> "" Then
        lEntriesPtr = lEntriesPtr + 1
        ReDim Preserve mudtDatabase(1 To lEntriesPtr)
        On Error Resume Next
        mudtDatabase(lEntriesPtr).BarCode = CStr(DBArray(lRow, lColBarCode))
        mudtDatabase(lEntriesPtr).Brand = NormaliseName(DBArray(lRow, lColBrand))
        mudtDatabase(lEntriesPtr).Qty = CStr(DBArray(lRow, lColQty))
        mudtDatabase(lEntriesPtr).Title = CStr(DBArray(lRow, lColTitle))
        On Error GoTo 0
    End If
Next lRow

End Sub

Private Function GetParameters() As Params
'***********************************************
'** Return parameters from sheet 'parameters' **
'***********************************************
Dim lRow As Long
Dim lEndRow As Long

Dim sCurKeyword As String
Dim sCurValue As String

Dim vaParamData As Variant

'** Store parameter data into array **
vaParamData = ThisWorkbook.Sheets("Parameters").Range("A1").CurrentRegion.Resize(, 2).Value

For lRow = 2 To UBound(vaParamData, 1)
    sCurKeyword = LCase$(Replace(vaParamData(lRow, 1), " ", ""))    '** Remove all spaces and convert to lowercase
    Select Case sCurKeyword
        Case ""             '** Ignore empty keyword cells **
            
        Case "groupheading"
            GetParameters.GroupHeading = NormaliseName(vaParamData(lRow, 2))
        Case "matchheading"
            GetParameters.MatchHeading = NormaliseName(vaParamData(lRow, 2))
        Case "#matchesperentry"
            GetParameters.MatchesCount = Val(vaParamData(lRow, 2))
        Case "min%match"
            GetParameters.MinPercent = Val(vaParamData(lRow, 2))
        Case "matchalgorithm"
            GetParameters.Algorithm = Val(vaParamData(lRow, 2))
        Case "dbquantity"
            GetParameters.DBQuantity = CStr(vaParamData(lRow, 2))
        Case "dbbarcode"
            GetParameters.DBBarcode = CStr(vaParamData(lRow, 2))
        Case "showdbtitle"
            GetParameters.ShowTitle = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
        Case "showdbquantity"
            GetParameters.ShowQty = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
    End Select
Next lRow

End Function
Private Function NormaliseName(ByVal NameX As String) As String
'*************************************************************************************
'** Remove all but "abcdefghijklmnopqrstuvwxyz0123456789", and convert to lowercase **
'*************************************************************************************
Dim lPtr As Long

Dim sChar As String
Dim sResult As String

For lPtr = 1 To Len(NameX)
    sChar = LCase$(Mid$(NameX, lPtr, 1))
    If InStr("abcdefghijklmnopqrstuvwxyz0123456789", sChar) > 0 Then sResult = sResult & sChar
Next lPtr
NormaliseName = sResult
End Function

Private Sub ProcessInputFile(ByVal DBData As Variant, _
                             ByVal InputFileName As Variant, _
                             ByRef ResultsWB As Workbook)

Dim lCol As Long
Dim lRow As Long
Dim lPtr As Long
Dim lMustMatchCol As Long
Dim lMatchCol As Long
Dim lLB As Long
Dim lUB As Long
Dim lDBRow As Long
Dim lPtr1 As Long
Dim lPtr2 As Long
Dim lSheetCount As Long
Dim lResultsColumnCount As Long

Dim sCurHeading As String
Dim sTerminalName As String
Dim sCurResellerBrand As String
Dim sCurResellerTitle As String
Dim sCurDBTitle As String

Dim sngCurMatchPercent As Single

Dim udtBarCodeMatches() As BarCodeMatches
Dim udtBrandBounds As BrandBounds

Dim vaCurData As Variant
Dim vaMatchResultsData As Variant
Dim vaCurBrandItem As Variant

Dim WB As Workbook

Dim WS As Worksheet
Dim wsResults As Worksheet

lMustMatchCol = 0
lMatchCol = 0

sTerminalName = GetTerminalName(InputFileName)

Application.StatusBar = "Processing " & sTerminalName
Application.ScreenUpdating = False

On Error Resume Next
Set WB = Nothing
Set WB = Workbooks.Open(Filename:=InputFileName, _
                        UpdateLinks:=True, _
                        ReadOnly:=True, _
                        corruptload:=xlRepairFile)
If Err.Number > 0 Then
    MsgBox prompt:=Err.Description, Buttons:=vbOKOnly + vbCritical, Title:="Unable to open file " & sTerminalName
End If
On Error GoTo 0
If WB Is Nothing Then Exit Sub

Set WS = WB.Sheets(1)
With WS.UsedRange
    vaCurData = WS.Range("A1").Resize(.Rows.Count, .Columns.Count).Value                '** Get input Reseller data
End With

'** Initialise results array **
lResultsColumnCount = 2
If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
ReDim vaMatchResultsData(1 To UBound(vaCurData, 1), 1 To mudtParameters.MatchesCount * lResultsColumnCount) '** set size of array for Results
For lCol = 1 To mudtParameters.MatchesCount
    lPtr = ((lCol - 1) * lResultsColumnCount) + 1
    vaMatchResultsData(1, lPtr) = "Barcode #" & lCol
    vaMatchResultsData(1, lPtr + 1) = "#" & lCol & " % Match"
    lPtr1 = lPtr + 1
    If mudtParameters.ShowTitle = True Then
        lPtr1 = lPtr1 + 1
        vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB " & mudtParameters.MatchHeading
    End If
    If mudtParameters.ShowQty = True Then
        lPtr1 = lPtr1 + 1
        vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB Quantity"
    End If
Next lCol

'** Check that we have the 2 required heading columns in row 1**
For lCol = 1 To UBound(vaCurData, 2)
    sCurHeading = NormaliseName(CStr(vaCurData(1, lCol)))
    If sCurHeading = mudtParameters.GroupHeading Then lMustMatchCol = lCol
    If sCurHeading = mudtParameters.MatchHeading Then lMatchCol = lCol
Next lCol
If lMustMatchCol > 0 _
And lMatchCol > 0 Then
    '** Process the reseller **
    lSheetCount = ResultsWB.Worksheets.Count
    Set wsResults = ResultsWB.Sheets.Add(after:=ResultsWB.Sheets(lSheetCount))        '** Add a new worksheet to the results workbook
    On Error Resume Next
    wsResults.Name = sTerminalName              '** set the sheetname to the reseller file terminal name
    On Error GoTo 0
    '** MAIN LOOP **
    For lRow = 2 To UBound(vaCurData, 1)
        With Application
            .ScreenUpdating = True
            .StatusBar = "Processing Reseller file " & sTerminalName & ", row " & lRow & " of " & UBound(vaCurData, 1)
            .ScreenUpdating = False
        End With
        sCurResellerBrand = NormaliseName(vaCurData(lRow, lMustMatchCol))
        sCurResellerTitle = vaCurData(lRow, lMatchCol)

        If CollectionKeyExists(coll:=mcolBrandbounds, key:=sCurResellerBrand) Then
            ReDim vaCurBrandItem(1 To 3)
            vaCurBrandItem = mcolBrandbounds.Item(sCurResellerBrand)
        
            '** Initialise array **
            ReDim udtBarCodeMatches(1 To mudtParameters.MatchesCount + 1)
            For lPtr = 1 To UBound(udtBarCodeMatches)
                With udtBarCodeMatches(lPtr)
                    .BarCode = ""
                    .BrandPercent = 0
                    .MatchText = ""
                    .Qty = ""
                End With
            Next lPtr
            
            sCurResellerTitle = vaCurData(lRow, lMatchCol)
            For lDBRow = vaCurBrandItem(2) To vaCurBrandItem(3)
                sngCurMatchPercent = FuzzyPercent(String1:=sCurResellerTitle, _
                                                  String2:=mudtDatabase(lDBRow).Title, _
                                                  Algorithm:=mudtParameters.Algorithm, _
                                                  Normalised:=False)
                If sngCurMatchPercent >= mudtParameters.MinPercent Then
                    For lPtr1 = 1 To mudtParameters.MatchesCount
                        If sngCurMatchPercent > udtBarCodeMatches(lPtr1).BrandPercent Then
                            For lPtr2 = mudtParameters.MatchesCount - 1 To lPtr1 Step -1
                                If udtBarCodeMatches(lPtr2).BrandPercent <> 0 Then
                                    With udtBarCodeMatches(lPtr2 + 1)
                                        .BarCode = udtBarCodeMatches(lPtr2).BarCode
                                        .BrandPercent = udtBarCodeMatches(lPtr2).BrandPercent
                                        .MatchText = udtBarCodeMatches(lPtr2).MatchText
                                        .Qty = udtBarCodeMatches(lPtr2).Qty
                                    End With
                                End If
                            Next lPtr2
                            With udtBarCodeMatches(lPtr1)
                                .BarCode = mudtDatabase(lDBRow).BarCode
                                .BrandPercent = sngCurMatchPercent
                                .MatchText = mudtDatabase(lDBRow).Title
                                .Qty = mudtDatabase(lDBRow).Qty
                            End With
                            Exit For
                        End If
                    Next lPtr1
                End If
            Next lDBRow
            For lCol = 1 To mudtParameters.MatchesCount
                If udtBarCodeMatches(lCol).BrandPercent > 0 Then
                    lPtr = ((lCol - 1) * lResultsColumnCount) + 1
                    vaMatchResultsData(lRow, lPtr) = "'" & udtBarCodeMatches(lCol).BarCode
                    vaMatchResultsData(lRow, lPtr + 1) = udtBarCodeMatches(lCol).BrandPercent
                    lPtr1 = lPtr + 1
                    If mudtParameters.ShowTitle = True Then
                        lPtr1 = lPtr1 + 1
                        vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).MatchText
                    End If
                    If mudtParameters.ShowQty = True Then
                        lPtr1 = lPtr1 + 1
                        vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).Qty
                    End If
                End If
            Next lCol
        End If
    Next lRow
    
    '** Store results into worksheet **
    wsResults.Range("A1").Resize(UBound(vaCurData, 1), UBound(vaCurData, 2)).Value = vaCurData
    lResultsColumnCount = 2
    If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
    If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
    With wsResults.Range("A1").Offset(, UBound(vaCurData, 2))
        For lCol = 1 To mudtParameters.MatchesCount
            lPtr = ((lCol - 1) * lResultsColumnCount)
            With .Offset(, lPtr + 1).Resize(wsResults.Rows.Count, 1)
                .NumberFormat = "0.00%"
                .HorizontalAlignment = xlLeft
            End With
        Next lCol
        .Resize(UBound(vaMatchResultsData, 1), UBound(vaMatchResultsData, 2)).Value = vaMatchResultsData
    End With
    wsResults.UsedRange.Resize(1).Font.Bold = True
    wsResults.Cells.EntireColumn.AutoFit
    
End If

WB.Close savechanges:=False

Application.ScreenUpdating = True

End Sub

Function CollectionKeyExists(coll As Collection, key As String) As Boolean

    On Error GoTo EH

    IsObject (coll.Item(key))
    
    CollectionKeyExists = True
EH:
End Function

Private Function GetTerminalName(ByVal Filenamex As Variant) As String
'*****************************************************************
'** Return final element of filename (excluding file extension) **
'*****************************************************************
Dim lUB As Long

Dim saSplit() As String
Dim saSplit2() As String

saSplit = Split(Filenamex, Delimiter:=Application.PathSeparator)
lUB = UBound(saSplit)
saSplit2 = Split(saSplit(lUB), ".")
GetTerminalName = saSplit2(0)
End Function

Sonny7 · Apr 14, 2024

Ok I just tried that and it worked, I got the prompt and could select and open my file Reseller_1.xls

However I got an error which has to do with FuzzyPercent it seems (see screenshot)

VBA Code:

         sngCurMatchPercent = FuzzyPercent(String1:=sCurResellerTitle, _
                                                  String2:=mudtDatabase(lDBRow).Title, _
                                                  Algorithm:=mudtParameters.Algorithm, _
                                                  Normalised:=False)

al_b_cnu · Apr 14, 2024

Hi Greg, Looks like you need to copy in the FuzzyVLookup code. Try copying the below into a new modude:

VBA 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.
'**                  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 one or  more offset columns which contain the group values.
'**                      Offsets are seperated by commas.
'**                      Default "0"
'**      GroupValue    : This parameter specifies the Group to be considered for matching.
'**                      If more than one GroupColOffset is specified, this value will be a concatenation of the
'**                      elements forming the group
'**                      If this parameter is blank, no group matching will occur.
'**
'** 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
'************************************************************************************************************

Dim mlRankOffset() As Long
Dim msngRankPercentage() As Single
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 String = "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 iaGroupColOffsets() As Integer
Dim iGroupHighestOffset As Integer

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 straGroupColOffsets() As String

Dim vCurValue As Variant
Dim vCurValues 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 mlRankOffset(1 To iRankHigh)
ReDim msngRankPercentage(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
        straGroupColOffsets = Split(GroupColOffset, ",")
        ReDim iaGroupColOffsets(0 To UBound(straGroupColOffsets))
        iGroupHighestOffset = 0
        For iPtr1 = 0 To UBound(straGroupColOffsets)
             iaGroupColOffsets(iPtr1) = Val(straGroupColOffsets(iPtr1))
             If iaGroupColOffsets(iPtr1) > iGroupHighestOffset Then iGroupHighestOffset = iaGroupColOffsets(iPtr1)
        Next iPtr1
        
        For Each rCur In rSearchRange
            If UBound(iaGroupColOffsets) = 0 Then
                vCurValue = rCur.Offset(, iaGroupColOffsets(0)).Value
            Else
                vCurValues = rCur.Resize(, iGroupHighestOffset + 1).Value
                vCurValue = ""
                For iPtr1 = 0 To UBound(iaGroupColOffsets)
                    vCurValue = vCurValue & CStr(vCurValues(1, iaGroupColOffsets(iPtr1) + 1))
                Next iPtr1
            End If
            If VarType(vCurValue) = vbString Or UBound(iaGroupColOffsets) > 0 Then
                bWanted = LCase$(CStr(vCurValue)) = LCase$(CStr(GroupValue))
            Else
                bWanted = Val(vCurValue) = Val(GroupValue)
            End If
            If bWanted Then
                FuzzyVlookupMain LookupValue:=LookupValue, _
                                TableArray:=rCur, _
                                IndexNum:=IndexNum, _
                                NFPercent:=sngNFPercent, _
                                Rank:=iRankHigh, _
                                Algorithm:=Algorithm, _
                                AdditionalCols:=AdditionalCols, _
                                LookupColOffset:=LookupColOffset
            End If
        Next rCur
    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 (msngRankPercentage(iaRank(1)) < sngNFPercent) _
    And (msngRankPercentage(iaRank(2)) < sngNFPercent) Then
        '--------------------------------------
        '-- Return '#N/A' if below NFPercent --
        '--------------------------------------
        FuzzyVLookup = CVErr(xlErrNA)
    Else
        sResult = ""
        For iPtr2 = iaRank(1) To iaRank(2) Step iRankStep
            If (msngRankPercentage(iPtr2) >= sngaNFPercent(0)) _
            And (msngRankPercentage(iPtr2) <= sngaNFPercent(1)) Then
                mlBestMatchPtr = mlRankOffset(iPtr2) - 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 > msngRankPercentage(intRankPtr) Then
mlRankOffset
msngRankPercentage
                For intRankPtr1 = Rank To intRankPtr + 1 Step -1
                    mlRankOffset(intRankPtr1) = mlRankOffset(intRankPtr1 - 1)
                    msngRankPercentage(intRankPtr1) = msngRankPercentage(intRankPtr1 - 1)
                Next intRankPtr1
                
                mlRankOffset(intRankPtr) = TableArray.Row
                msngRankPercentage(intRankPtr1) = sngCurPercent
                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

Sonny7 · Apr 14, 2024

Ok great, I managed to make it work!
It did sort out the file with my example very well, the result is really impressive

However, I tried with a larger sample (nearly 40.000 products) and I got a strange error about the sorting.
A prompt says:

VBA Code:

Database Data Error

Database file MUST be sorted into ascending Brand sequence

But actually I did sort out the Brand column in ascending sequence, so something might be blocking it? An accent or a caracter maybe?
I'm putting my file with a Brand list in this GSheet, maybe you can try on your side?

Fuzzy Match - Missing Barcode

al_b_cnu · Apr 14, 2024

Hi Greg,
Actually the code "normalises" the brand by converting to lowercase and removing all but alphanumerics. That may be the cause. This modified code will report the row in the database at which it found the sequence error, if you'd like to have another try:

VBA Code:

Option Explicit

Type Params
    GroupHeading As String
    MatchHeading As String
    MatchesCount As Long
    MinPercent As Single
    Algorithm As Single
    DBQuantity As String
    DBBarcode As String
    ShowTitle As Boolean
    ShowQty As Boolean
End Type
Dim mudtParameters As Params

Type BrandBounds
    BrandName As String
    BrandLB As Long
    BrandUB As Long
End Type

Dim mcolBrandbounds As Collection

Type DatabaseData
    Brand As String
    Title As String
    Qty As String
    BarCode As String
End Type
Dim mudtDatabase() As DatabaseData

Type BarCodeMatches
    BarCode As String
    BrandPercent As Single
    MatchText As String
    Qty As String
End Type

Sub click_GetBarcodes()

Dim lUB As Long
Dim lLastUB  As Long
Dim lRow As Long

Dim saCurName() As String
Dim sCurTerminalName As String
Dim sPrevBrand As String
Dim sCurBrand As String

Dim vCurFilename As Variant
Dim vResellerFiles As Variant
Dim vaDatabase As Variant
Dim vaBrandLimits As Variant
Dim vaDicBrandItem As Variant
Dim vaBrandBounds As Variant

Dim udtBrandBound As BrandBounds

Dim WBcur As Workbook
Dim wbResults As Workbook

Dim wsDB As Worksheet
Dim wsCur As Worksheet

'MsgBox Application.OperatingSystem

mudtParameters = GetParameters()

Application.DisplayAlerts = False

'*********************************
'**Get database data into array **
'*********************************
Set wsDB = ThisWorkbook.Sheets("Database")
With wsDB.UsedRange
    vaDatabase = wsDB.Range("A1").Resize(.Rows.Count, .Columns.Count).Value
End With

'*************************************************************************************
'** Set up Brands bounds collection                                              **
'** Note that the database entries MUST be sorted into ascending brand sequence!    **
'*************************************************************************************
Set mcolBrandbounds = New Collection
lUB = 0
sPrevBrand = ""
ReDim vaBrandBounds(1 To 3)
For lRow = 2 To UBound(vaDatabase, 1)
    sCurBrand = NormaliseName(vaDatabase(lRow, 1))
    If sCurBrand <> "" Then
        If sCurBrand < sPrevBrand Then
            MsgBox prompt:="Database not sorted into ascending Brand sequence at row " & lRow, _
                    Buttons:=vbOKOnly + vbCritical, _
                    Title:="Database Sequence Error"
            Set mcolBrandbounds = Nothing
            Exit Sub

        ElseIf sCurBrand = sPrevBrand Then
            '** Update End row for current brand
            vaBrandBounds(3) = lRow
        Else
            '** Here if new brand entry row encountered **
            If sPrevBrand <> "" Then
                On Error Resume Next
                mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds
                On Error GoTo 0
            End If
            vaBrandBounds(1) = sCurBrand
            vaBrandBounds(2) = lRow
            vaBrandBounds(3) = lRow
            
            sPrevBrand = sCurBrand
            
        End If
    End If
Next lRow
On Error Resume Next
mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds        '** Write final entry **
On Error GoTo 0

'**************************************************
'** Store database in the udt array mudtDatabase **
'**************************************************
Call PopulateDatabaseEntries(DBArray:=vaDatabase)

'***********************************
'** Get input reseller file names **
'***********************************
If InStr(1, Application.OperatingSystem, "Windows") = 0 Then
    vResellerFiles = Application.GetOpenFilename(Title:="Please select Reseller Excel file")
Else
    vResellerFiles = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", _
                                                Title:="Please select Reseller Excel file(s)", _
                                                MultiSelect:=True)
    If IsArray(vResellerFiles) = False Then Exit Sub
End If

'****************************
'** Create output workbook **
'****************************
Set wbResults = Nothing
On Error Resume Next
Set wbResults = Workbooks.Add
On Error GoTo 0
If wbResults Is Nothing Then
    If Err.Number > 0 Then
        MsgBox prompt:=Err.Description, _
                Buttons:=vbOKOnly + vbCritical, _
                Title:="Cannot create Results Workbook"
        
    End If
    Exit Sub
End If

'******************************
'** Process Reseller file(s) **
'******************************
If IsArray(vResellerFiles) Then
    For Each vCurFilename In vResellerFiles
        
        Call ProcessInputFile(DBData:=vaDatabase, _
                              InputFileName:=vCurFilename, _
                              ResultsWB:=wbResults)
        
    Next vCurFilename
Else
        Call ProcessInputFile(DBData:=vaDatabase, _
                          InputFileName:=vResellerFiles, _
                          ResultsWB:=wbResults)
End If

On Error Resume Next
wbResults.Sheets(1).Delete
Set mcolBrandbounds = Nothing
On Error GoTo 0

Application.StatusBar = False

End Sub

Private Sub PopulateDatabaseEntries(ByVal DBArray As Variant)
'************************************
'** Create entries in mudtDataBase **
'************************************
Dim lRow As Long
Dim lCol As Long
Dim lColBrand As Long
Dim lColTitle As Long
Dim lColQty As Long
Dim lColBarCode As Long
Dim lEntriesPtr As Long

Dim sCurHeading As String

For lCol = 1 To UBound(DBArray, 2)
    sCurHeading = NormaliseName(CStr(DBArray(1, lCol)))
    Select Case sCurHeading
        Case NormaliseName(mudtParameters.GroupHeading)
            lColBrand = lCol
        Case NormaliseName(mudtParameters.MatchHeading)
            lColTitle = lCol
        Case NormaliseName(mudtParameters.DBQuantity)
            lColQty = lCol
        Case NormaliseName(mudtParameters.DBBarcode)
            lColBarCode = lCol
    End Select
Next lCol

ReDim mudtDatabase(1 To 1)
lEntriesPtr = 1
mudtDatabase(1).Brand = ""
On Error Resume Next
For lRow = 2 To UBound(DBArray, 1)
    If Trim$(DBArray(lRow, lColBrand)) <> "" Then
        lEntriesPtr = lEntriesPtr + 1
        ReDim Preserve mudtDatabase(1 To lEntriesPtr)
        On Error Resume Next
        mudtDatabase(lEntriesPtr).BarCode = CStr(DBArray(lRow, lColBarCode))
        mudtDatabase(lEntriesPtr).Brand = NormaliseName(DBArray(lRow, lColBrand))
        mudtDatabase(lEntriesPtr).Qty = CStr(DBArray(lRow, lColQty))
        mudtDatabase(lEntriesPtr).Title = CStr(DBArray(lRow, lColTitle))
        On Error GoTo 0
    End If
Next lRow

End Sub

Private Function GetParameters() As Params
'***********************************************
'** Return parameters from sheet 'parameters' **
'***********************************************
Dim lRow As Long
Dim lEndRow As Long

Dim sCurKeyword As String
Dim sCurValue As String

Dim vaParamData As Variant

'** Store parameter data into array **
vaParamData = ThisWorkbook.Sheets("Parameters").Range("A1").CurrentRegion.Resize(, 2).Value

For lRow = 2 To UBound(vaParamData, 1)
    sCurKeyword = LCase$(Replace(vaParamData(lRow, 1), " ", ""))    '** Remove all spaces and convert to lowercase
    Select Case sCurKeyword
        Case ""             '** Ignore empty keyword cells **
            
        Case "groupheading"
            GetParameters.GroupHeading = NormaliseName(vaParamData(lRow, 2))
        Case "matchheading"
            GetParameters.MatchHeading = NormaliseName(vaParamData(lRow, 2))
        Case "#matchesperentry"
            GetParameters.MatchesCount = Val(vaParamData(lRow, 2))
        Case "min%match"
            GetParameters.MinPercent = Val(vaParamData(lRow, 2))
        Case "matchalgorithm"
            GetParameters.Algorithm = Val(vaParamData(lRow, 2))
        Case "dbquantity"
            GetParameters.DBQuantity = CStr(vaParamData(lRow, 2))
        Case "dbbarcode"
            GetParameters.DBBarcode = CStr(vaParamData(lRow, 2))
        Case "showdbtitle"
            GetParameters.ShowTitle = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
        Case "showdbquantity"
            GetParameters.ShowQty = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
    End Select
Next lRow

End Function
Private Function NormaliseName(ByVal NameX As String) As String
'*************************************************************************************
'** Remove all but "abcdefghijklmnopqrstuvwxyz0123456789", and convert to lowercase **
'*************************************************************************************
Dim lPtr As Long

Dim sChar As String
Dim sResult As String

For lPtr = 1 To Len(NameX)
    sChar = LCase$(Mid$(NameX, lPtr, 1))
    If InStr("abcdefghijklmnopqrstuvwxyz0123456789", sChar) > 0 Then sResult = sResult & sChar
Next lPtr
NormaliseName = sResult
End Function

Private Sub ProcessInputFile(ByVal DBData As Variant, _
                             ByVal InputFileName As Variant, _
                             ByRef ResultsWB As Workbook)

Dim lCol As Long
Dim lRow As Long
Dim lPtr As Long
Dim lMustMatchCol As Long
Dim lMatchCol As Long
Dim lLB As Long
Dim lUB As Long
Dim lDBRow As Long
Dim lPtr1 As Long
Dim lPtr2 As Long
Dim lSheetCount As Long
Dim lResultsColumnCount As Long

Dim sCurHeading As String
Dim sTerminalName As String
Dim sCurResellerBrand As String
Dim sCurResellerTitle As String
Dim sCurDBTitle As String

Dim sngCurMatchPercent As Single

Dim udtBarCodeMatches() As BarCodeMatches
Dim udtBrandBounds As BrandBounds

Dim vaCurData As Variant
Dim vaMatchResultsData As Variant
Dim vaCurBrandItem As Variant

Dim WB As Workbook

Dim WS As Worksheet
Dim wsResults As Worksheet

lMustMatchCol = 0
lMatchCol = 0

sTerminalName = GetTerminalName(InputFileName)

Application.StatusBar = "Processing " & sTerminalName
Application.ScreenUpdating = False

On Error Resume Next
Set WB = Nothing
Set WB = Workbooks.Open(Filename:=InputFileName, _
                        UpdateLinks:=True, _
                        ReadOnly:=True, _
                        corruptload:=xlRepairFile)
If Err.Number > 0 Then
    MsgBox prompt:=Err.Description, Buttons:=vbOKOnly + vbCritical, Title:="Unable to open file " & sTerminalName
End If
On Error GoTo 0
If WB Is Nothing Then Exit Sub

Set WS = WB.Sheets(1)
With WS.UsedRange
    vaCurData = WS.Range("A1").Resize(.Rows.Count, .Columns.Count).Value                '** Get input Reseller data
End With

'** Initialise results array **
lResultsColumnCount = 2
If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
ReDim vaMatchResultsData(1 To UBound(vaCurData, 1), 1 To mudtParameters.MatchesCount * lResultsColumnCount) '** set size of array for Results
For lCol = 1 To mudtParameters.MatchesCount
    lPtr = ((lCol - 1) * lResultsColumnCount) + 1
    vaMatchResultsData(1, lPtr) = "Barcode #" & lCol
    vaMatchResultsData(1, lPtr + 1) = "#" & lCol & " % Match"
    lPtr1 = lPtr + 1
    If mudtParameters.ShowTitle = True Then
        lPtr1 = lPtr1 + 1
        vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB " & mudtParameters.MatchHeading
    End If
    If mudtParameters.ShowQty = True Then
        lPtr1 = lPtr1 + 1
        vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB Quantity"
    End If
Next lCol

'** Check that we have the 2 required heading columns in row 1**
For lCol = 1 To UBound(vaCurData, 2)
    sCurHeading = NormaliseName(CStr(vaCurData(1, lCol)))
    If sCurHeading = mudtParameters.GroupHeading Then lMustMatchCol = lCol
    If sCurHeading = mudtParameters.MatchHeading Then lMatchCol = lCol
Next lCol
If lMustMatchCol > 0 _
And lMatchCol > 0 Then
    '** Process the reseller **
    lSheetCount = ResultsWB.Worksheets.Count
    Set wsResults = ResultsWB.Sheets.Add(after:=ResultsWB.Sheets(lSheetCount))        '** Add a new worksheet to the results workbook
    On Error Resume Next
    wsResults.Name = sTerminalName              '** set the sheetname to the reseller file terminal name
    On Error GoTo 0
    '** MAIN LOOP **
    For lRow = 2 To UBound(vaCurData, 1)
        With Application
            .ScreenUpdating = True
            .StatusBar = "Processing Reseller file " & sTerminalName & ", row " & lRow & " of " & UBound(vaCurData, 1)
            .ScreenUpdating = False
        End With
        sCurResellerBrand = NormaliseName(vaCurData(lRow, lMustMatchCol))
        sCurResellerTitle = vaCurData(lRow, lMatchCol)

        If CollectionKeyExists(coll:=mcolBrandbounds, key:=sCurResellerBrand) Then
            ReDim vaCurBrandItem(1 To 3)
            vaCurBrandItem = mcolBrandbounds.Item(sCurResellerBrand)
        
            '** Initialise array **
            ReDim udtBarCodeMatches(1 To mudtParameters.MatchesCount + 1)
            For lPtr = 1 To UBound(udtBarCodeMatches)
                With udtBarCodeMatches(lPtr)
                    .BarCode = ""
                    .BrandPercent = 0
                    .MatchText = ""
                    .Qty = ""
                End With
            Next lPtr
            
            sCurResellerTitle = vaCurData(lRow, lMatchCol)
            For lDBRow = vaCurBrandItem(2) To vaCurBrandItem(3)
                sngCurMatchPercent = FuzzyPercent(String1:=sCurResellerTitle, _
                                                  String2:=mudtDatabase(lDBRow).Title, _
                                                  Algorithm:=mudtParameters.Algorithm, _
                                                  Normalised:=False)
                If sngCurMatchPercent >= mudtParameters.MinPercent Then
                    For lPtr1 = 1 To mudtParameters.MatchesCount
                        If sngCurMatchPercent > udtBarCodeMatches(lPtr1).BrandPercent Then
                            For lPtr2 = mudtParameters.MatchesCount - 1 To lPtr1 Step -1
                                If udtBarCodeMatches(lPtr2).BrandPercent <> 0 Then
                                    With udtBarCodeMatches(lPtr2 + 1)
                                        .BarCode = udtBarCodeMatches(lPtr2).BarCode
                                        .BrandPercent = udtBarCodeMatches(lPtr2).BrandPercent
                                        .MatchText = udtBarCodeMatches(lPtr2).MatchText
                                        .Qty = udtBarCodeMatches(lPtr2).Qty
                                    End With
                                End If
                            Next lPtr2
                            With udtBarCodeMatches(lPtr1)
                                .BarCode = mudtDatabase(lDBRow).BarCode
                                .BrandPercent = sngCurMatchPercent
                                .MatchText = mudtDatabase(lDBRow).Title
                                .Qty = mudtDatabase(lDBRow).Qty
                            End With
                            Exit For
                        End If
                    Next lPtr1
                End If
            Next lDBRow
            For lCol = 1 To mudtParameters.MatchesCount
                If udtBarCodeMatches(lCol).BrandPercent > 0 Then
                    lPtr = ((lCol - 1) * lResultsColumnCount) + 1
                    vaMatchResultsData(lRow, lPtr) = "'" & udtBarCodeMatches(lCol).BarCode
                    vaMatchResultsData(lRow, lPtr + 1) = udtBarCodeMatches(lCol).BrandPercent
                    lPtr1 = lPtr + 1
                    If mudtParameters.ShowTitle = True Then
                        lPtr1 = lPtr1 + 1
                        vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).MatchText
                    End If
                    If mudtParameters.ShowQty = True Then
                        lPtr1 = lPtr1 + 1
                        vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).Qty
                    End If
                End If
            Next lCol
        End If
    Next lRow
    
    '** Store results into worksheet **
    wsResults.Range("A1").Resize(UBound(vaCurData, 1), UBound(vaCurData, 2)).Value = vaCurData
    lResultsColumnCount = 2
    If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
    If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
    With wsResults.Range("A1").Offset(, UBound(vaCurData, 2))
        For lCol = 1 To mudtParameters.MatchesCount
            lPtr = ((lCol - 1) * lResultsColumnCount)
            With .Offset(, lPtr + 1).Resize(wsResults.Rows.Count, 1)
                .NumberFormat = "0.00%"
                .HorizontalAlignment = xlLeft
            End With
        Next lCol
        .Resize(UBound(vaMatchResultsData, 1), UBound(vaMatchResultsData, 2)).Value = vaMatchResultsData
    End With
    wsResults.UsedRange.Resize(1).Font.Bold = True
    wsResults.Cells.EntireColumn.AutoFit
    
End If

WB.Close savechanges:=False

Application.ScreenUpdating = True

End Sub

Function CollectionKeyExists(coll As Collection, key As String) As Boolean

    On Error GoTo EH

    IsObject (coll.Item(key))
    
    CollectionKeyExists = True
EH:
End Function

Private Function GetTerminalName(ByVal Filenamex As Variant) As String
'*****************************************************************
'** Return final element of filename (excluding file extension) **
'*****************************************************************
Dim lUB As Long

Dim saSplit() As String
Dim saSplit2() As String

saSplit = Split(Filenamex, Delimiter:=Application.PathSeparator)
lUB = UBound(saSplit)
saSplit2 = Split(saSplit(lUB), ".")
GetTerminalName = saSplit2(0)
End Function

Sonny7 · Apr 14, 2024

Oh ok I understand but unfortunately I got a different error this time, likely related to that still

Database Sequence Error:
Database not sorted into ascending Brand sequence at row 16

Raw 16 should correspond to 4LIVING on my list but I think it's the title on column B that creates a problem this time, also due to characters and I think the quote sign ""
(I updated the list on my GSheet with the corresponding titles)

Unfortunately I'm gonna have all the possible accents, numbers or various characters in my files, possibly even Cyrilic letters sometimes

Fuzzy Match - Missing Barcode

al_b_cnu · Apr 14, 2024

Ah ok I now understand the issue.
Row 15 is "4 Seasons" which, when normalised, becomes "4seasons"
Row 16 is "4LIVING" which, when normalised, becomes "4living" which would sort to lower than "4seasons". I have amended the code to not insist on strict sort sequence BUT to insist that each group of brands is unique which should fix it:

VBA Code:

Option Explicit

Type Params
    GroupHeading As String
    MatchHeading As String
    MatchesCount As Long
    MinPercent As Single
    Algorithm As Single
    DBQuantity As String
    DBBarcode As String
    ShowTitle As Boolean
    ShowQty As Boolean
End Type
Dim mudtParameters As Params

Type BrandBounds
    BrandName As String
    BrandLB As Long
    BrandUB As Long
End Type

Dim mcolBrandbounds As Collection

Type DatabaseData
    Brand As String
    Title As String
    Qty As String
    BarCode As String
End Type
Dim mudtDatabase() As DatabaseData

Type BarCodeMatches
    BarCode As String
    BrandPercent As Single
    MatchText As String
    Qty As String
End Type

Sub click_GetBarcodes()

Dim lUB As Long
Dim lLastUB  As Long
Dim lRow As Long

Dim saCurName() As String
Dim sCurTerminalName As String
Dim sPrevBrand As String
Dim sCurBrand As String

Dim vCurFilename As Variant
Dim vResellerFiles As Variant
Dim vaDatabase As Variant
Dim vaBrandLimits As Variant
Dim vaDicBrandItem As Variant
Dim vaBrandBounds As Variant

Dim udtBrandBound As BrandBounds

Dim WBcur As Workbook
Dim wbResults As Workbook

Dim wsDB As Worksheet
Dim wsCur As Worksheet

'MsgBox Application.OperatingSystem

mudtParameters = GetParameters()

Application.DisplayAlerts = False

'*********************************
'**Get database data into array **
'*********************************
Set wsDB = ThisWorkbook.Sheets("Database")
With wsDB.UsedRange
    vaDatabase = wsDB.Range("A1").Resize(.Rows.Count, .Columns.Count).Value
End With

'*************************************************************************************
'** Set up Brands bounds collection                                              **
'** Note that the database entries MUST be sorted into ascending brand sequence!    **
'*************************************************************************************
Set mcolBrandbounds = New Collection
lUB = 0
sPrevBrand = ""
ReDim vaBrandBounds(1 To 3)
For lRow = 2 To UBound(vaDatabase, 1)
    sCurBrand = NormaliseName(vaDatabase(lRow, 1))
    If sCurBrand <> "" Then
        If sCurBrand < sPrevBrand Then
'            MsgBox prompt:="Database not sorted into ascending Brand sequence at row " & lRow, _
'                    Buttons:=vbOKOnly + vbCritical, _
'                    Title:="Database Sequence Error"
'            Set mcolBrandbounds = Nothing
'            Exit Sub

        ElseIf sCurBrand = sPrevBrand Then
            '** Update End row for current brand
            vaBrandBounds(3) = lRow
        Else
            '** Here if new brand entry row encountered **
            If sPrevBrand <> "" Then
                If CollectionKeyExists(coll:=mcolBrandbounds, key:=sPrevBrand) Then
                    MsgBox prompt:="Brand key " & sPrevBrand & " at row " & lRow & " already exists", _
                            Buttons:=vbOKOnly + vbCritical, _
                            Title:="Database sequence error"
                    Set mcolBrandbounds = Nothing
                    Exit Sub
                End If
                On Error Resume Next
                mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds
                On Error GoTo 0
            End If
            vaBrandBounds(1) = sCurBrand
            vaBrandBounds(2) = lRow
            vaBrandBounds(3) = lRow
            
            sPrevBrand = sCurBrand
            
        End If
    End If
Next lRow
On Error Resume Next
mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds        '** Write final entry **
On Error GoTo 0

'**************************************************
'** Store database in the udt array mudtDatabase **
'**************************************************
Call PopulateDatabaseEntries(DBArray:=vaDatabase)

'***********************************
'** Get input reseller file names **
'***********************************
If InStr(1, Application.OperatingSystem, "Windows") = 0 Then
    vResellerFiles = Application.GetOpenFilename(Title:="Please select Reseller Excel file")
Else
    vResellerFiles = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", _
                                                Title:="Please select Reseller Excel file(s)", _
                                                MultiSelect:=True)
    If IsArray(vResellerFiles) = False Then Exit Sub
End If

'****************************
'** Create output workbook **
'****************************
Set wbResults = Nothing
On Error Resume Next
Set wbResults = Workbooks.Add
On Error GoTo 0
If wbResults Is Nothing Then
    If Err.Number > 0 Then
        MsgBox prompt:=Err.Description, _
                Buttons:=vbOKOnly + vbCritical, _
                Title:="Cannot create Results Workbook"
        
    End If
    Exit Sub
End If

'******************************
'** Process Reseller file(s) **
'******************************
If IsArray(vResellerFiles) Then
    For Each vCurFilename In vResellerFiles
        
        Call ProcessInputFile(DBData:=vaDatabase, _
                              InputFileName:=vCurFilename, _
                              ResultsWB:=wbResults)
        
    Next vCurFilename
Else
        Call ProcessInputFile(DBData:=vaDatabase, _
                          InputFileName:=vResellerFiles, _
                          ResultsWB:=wbResults)
End If

On Error Resume Next
wbResults.Sheets(1).Delete
Set mcolBrandbounds = Nothing
On Error GoTo 0

Application.StatusBar = False

End Sub

Private Sub PopulateDatabaseEntries(ByVal DBArray As Variant)
'************************************
'** Create entries in mudtDataBase **
'************************************
Dim lRow As Long
Dim lCol As Long
Dim lColBrand As Long
Dim lColTitle As Long
Dim lColQty As Long
Dim lColBarCode As Long
Dim lEntriesPtr As Long

Dim sCurHeading As String

For lCol = 1 To UBound(DBArray, 2)
    sCurHeading = NormaliseName(CStr(DBArray(1, lCol)))
    Select Case sCurHeading
        Case NormaliseName(mudtParameters.GroupHeading)
            lColBrand = lCol
        Case NormaliseName(mudtParameters.MatchHeading)
            lColTitle = lCol
        Case NormaliseName(mudtParameters.DBQuantity)
            lColQty = lCol
        Case NormaliseName(mudtParameters.DBBarcode)
            lColBarCode = lCol
    End Select
Next lCol

ReDim mudtDatabase(1 To 1)
lEntriesPtr = 1
mudtDatabase(1).Brand = ""
On Error Resume Next
For lRow = 2 To UBound(DBArray, 1)
    If Trim$(DBArray(lRow, lColBrand)) <> "" Then
        lEntriesPtr = lEntriesPtr + 1
        ReDim Preserve mudtDatabase(1 To lEntriesPtr)
        On Error Resume Next
        mudtDatabase(lEntriesPtr).BarCode = CStr(DBArray(lRow, lColBarCode))
        mudtDatabase(lEntriesPtr).Brand = NormaliseName(DBArray(lRow, lColBrand))
        mudtDatabase(lEntriesPtr).Qty = CStr(DBArray(lRow, lColQty))
        mudtDatabase(lEntriesPtr).Title = CStr(DBArray(lRow, lColTitle))
        On Error GoTo 0
    End If
Next lRow

End Sub

Private Function GetParameters() As Params
'***********************************************
'** Return parameters from sheet 'parameters' **
'***********************************************
Dim lRow As Long
Dim lEndRow As Long

Dim sCurKeyword As String
Dim sCurValue As String

Dim vaParamData As Variant

'** Store parameter data into array **
vaParamData = ThisWorkbook.Sheets("Parameters").Range("A1").CurrentRegion.Resize(, 2).Value

For lRow = 2 To UBound(vaParamData, 1)
    sCurKeyword = LCase$(Replace(vaParamData(lRow, 1), " ", ""))    '** Remove all spaces and convert to lowercase
    Select Case sCurKeyword
        Case ""             '** Ignore empty keyword cells **
            
        Case "groupheading"
            GetParameters.GroupHeading = NormaliseName(vaParamData(lRow, 2))
        Case "matchheading"
            GetParameters.MatchHeading = NormaliseName(vaParamData(lRow, 2))
        Case "#matchesperentry"
            GetParameters.MatchesCount = Val(vaParamData(lRow, 2))
        Case "min%match"
            GetParameters.MinPercent = Val(vaParamData(lRow, 2))
        Case "matchalgorithm"
            GetParameters.Algorithm = Val(vaParamData(lRow, 2))
        Case "dbquantity"
            GetParameters.DBQuantity = CStr(vaParamData(lRow, 2))
        Case "dbbarcode"
            GetParameters.DBBarcode = CStr(vaParamData(lRow, 2))
        Case "showdbtitle"
            GetParameters.ShowTitle = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
        Case "showdbquantity"
            GetParameters.ShowQty = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
    End Select
Next lRow

End Function
Private Function NormaliseName(ByVal NameX As String) As String
'*************************************************************************************
'** Remove all but "abcdefghijklmnopqrstuvwxyz0123456789", and convert to lowercase **
'*************************************************************************************
Dim lPtr As Long

Dim sChar As String
Dim sResult As String

For lPtr = 1 To Len(NameX)
    sChar = LCase$(Mid$(NameX, lPtr, 1))
    If InStr("abcdefghijklmnopqrstuvwxyz0123456789", sChar) > 0 Then sResult = sResult & sChar
Next lPtr
NormaliseName = sResult
End Function

Private Sub ProcessInputFile(ByVal DBData As Variant, _
                             ByVal InputFileName As Variant, _
                             ByRef ResultsWB As Workbook)

Dim lCol As Long
Dim lRow As Long
Dim lPtr As Long
Dim lMustMatchCol As Long
Dim lMatchCol As Long
Dim lLB As Long
Dim lUB As Long
Dim lDBRow As Long
Dim lPtr1 As Long
Dim lPtr2 As Long
Dim lSheetCount As Long
Dim lResultsColumnCount As Long

Dim sCurHeading As String
Dim sTerminalName As String
Dim sCurResellerBrand As String
Dim sCurResellerTitle As String
Dim sCurDBTitle As String

Dim sngCurMatchPercent As Single

Dim udtBarCodeMatches() As BarCodeMatches
Dim udtBrandBounds As BrandBounds

Dim vaCurData As Variant
Dim vaMatchResultsData As Variant
Dim vaCurBrandItem As Variant

Dim WB As Workbook

Dim WS As Worksheet
Dim wsResults As Worksheet

lMustMatchCol = 0
lMatchCol = 0

sTerminalName = GetTerminalName(InputFileName)

Application.StatusBar = "Processing " & sTerminalName
Application.ScreenUpdating = False

On Error Resume Next
Set WB = Nothing
Set WB = Workbooks.Open(Filename:=InputFileName, _
                        UpdateLinks:=True, _
                        ReadOnly:=True, _
                        corruptload:=xlRepairFile)
If Err.Number > 0 Then
    MsgBox prompt:=Err.Description, Buttons:=vbOKOnly + vbCritical, Title:="Unable to open file " & sTerminalName
End If
On Error GoTo 0
If WB Is Nothing Then Exit Sub

Set WS = WB.Sheets(1)
With WS.UsedRange
    vaCurData = WS.Range("A1").Resize(.Rows.Count, .Columns.Count).Value                '** Get input Reseller data
End With

'** Initialise results array **
lResultsColumnCount = 2
If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
ReDim vaMatchResultsData(1 To UBound(vaCurData, 1), 1 To mudtParameters.MatchesCount * lResultsColumnCount) '** set size of array for Results
For lCol = 1 To mudtParameters.MatchesCount
    lPtr = ((lCol - 1) * lResultsColumnCount) + 1
    vaMatchResultsData(1, lPtr) = "Barcode #" & lCol
    vaMatchResultsData(1, lPtr + 1) = "#" & lCol & " % Match"
    lPtr1 = lPtr + 1
    If mudtParameters.ShowTitle = True Then
        lPtr1 = lPtr1 + 1
        vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB " & mudtParameters.MatchHeading
    End If
    If mudtParameters.ShowQty = True Then
        lPtr1 = lPtr1 + 1
        vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB Quantity"
    End If
Next lCol

'** Check that we have the 2 required heading columns in row 1**
For lCol = 1 To UBound(vaCurData, 2)
    sCurHeading = NormaliseName(CStr(vaCurData(1, lCol)))
    If sCurHeading = mudtParameters.GroupHeading Then lMustMatchCol = lCol
    If sCurHeading = mudtParameters.MatchHeading Then lMatchCol = lCol
Next lCol
If lMustMatchCol > 0 _
And lMatchCol > 0 Then
    '** Process the reseller **
    lSheetCount = ResultsWB.Worksheets.Count
    Set wsResults = ResultsWB.Sheets.Add(after:=ResultsWB.Sheets(lSheetCount))        '** Add a new worksheet to the results workbook
    On Error Resume Next
    wsResults.Name = sTerminalName              '** set the sheetname to the reseller file terminal name
    On Error GoTo 0
    '** MAIN LOOP **
    For lRow = 2 To UBound(vaCurData, 1)
        With Application
            .ScreenUpdating = True
            .StatusBar = "Processing Reseller file " & sTerminalName & ", row " & lRow & " of " & UBound(vaCurData, 1)
            .ScreenUpdating = False
        End With
        sCurResellerBrand = NormaliseName(vaCurData(lRow, lMustMatchCol))
        sCurResellerTitle = vaCurData(lRow, lMatchCol)

        If CollectionKeyExists(coll:=mcolBrandbounds, key:=sCurResellerBrand) Then
            ReDim vaCurBrandItem(1 To 3)
            vaCurBrandItem = mcolBrandbounds.Item(sCurResellerBrand)
        
            '** Initialise array **
            ReDim udtBarCodeMatches(1 To mudtParameters.MatchesCount + 1)
            For lPtr = 1 To UBound(udtBarCodeMatches)
                With udtBarCodeMatches(lPtr)
                    .BarCode = ""
                    .BrandPercent = 0
                    .MatchText = ""
                    .Qty = ""
                End With
            Next lPtr
            
            sCurResellerTitle = vaCurData(lRow, lMatchCol)
            For lDBRow = vaCurBrandItem(2) To vaCurBrandItem(3)
                sngCurMatchPercent = FuzzyPercent(String1:=sCurResellerTitle, _
                                                  String2:=mudtDatabase(lDBRow).Title, _
                                                  Algorithm:=mudtParameters.Algorithm, _
                                                  Normalised:=False)
                If sngCurMatchPercent >= mudtParameters.MinPercent Then
                    For lPtr1 = 1 To mudtParameters.MatchesCount
                        If sngCurMatchPercent > udtBarCodeMatches(lPtr1).BrandPercent Then
                            For lPtr2 = mudtParameters.MatchesCount - 1 To lPtr1 Step -1
                                If udtBarCodeMatches(lPtr2).BrandPercent <> 0 Then
                                    With udtBarCodeMatches(lPtr2 + 1)
                                        .BarCode = udtBarCodeMatches(lPtr2).BarCode
                                        .BrandPercent = udtBarCodeMatches(lPtr2).BrandPercent
                                        .MatchText = udtBarCodeMatches(lPtr2).MatchText
                                        .Qty = udtBarCodeMatches(lPtr2).Qty
                                    End With
                                End If
                            Next lPtr2
                            With udtBarCodeMatches(lPtr1)
                                .BarCode = mudtDatabase(lDBRow).BarCode
                                .BrandPercent = sngCurMatchPercent
                                .MatchText = mudtDatabase(lDBRow).Title
                                .Qty = mudtDatabase(lDBRow).Qty
                            End With
                            Exit For
                        End If
                    Next lPtr1
                End If
            Next lDBRow
            For lCol = 1 To mudtParameters.MatchesCount
                If udtBarCodeMatches(lCol).BrandPercent > 0 Then
                    lPtr = ((lCol - 1) * lResultsColumnCount) + 1
                    vaMatchResultsData(lRow, lPtr) = "'" & udtBarCodeMatches(lCol).BarCode
                    vaMatchResultsData(lRow, lPtr + 1) = udtBarCodeMatches(lCol).BrandPercent
                    lPtr1 = lPtr + 1
                    If mudtParameters.ShowTitle = True Then
                        lPtr1 = lPtr1 + 1
                        vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).MatchText
                    End If
                    If mudtParameters.ShowQty = True Then
                        lPtr1 = lPtr1 + 1
                        vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).Qty
                    End If
                End If
            Next lCol
        End If
    Next lRow
    
    '** Store results into worksheet **
    wsResults.Range("A1").Resize(UBound(vaCurData, 1), UBound(vaCurData, 2)).Value = vaCurData
    lResultsColumnCount = 2
    If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
    If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
    With wsResults.Range("A1").Offset(, UBound(vaCurData, 2))
        For lCol = 1 To mudtParameters.MatchesCount
            lPtr = ((lCol - 1) * lResultsColumnCount)
            With .Offset(, lPtr + 1).Resize(wsResults.Rows.Count, 1)
                .NumberFormat = "0.00%"
                .HorizontalAlignment = xlLeft
            End With
        Next lCol
        .Resize(UBound(vaMatchResultsData, 1), UBound(vaMatchResultsData, 2)).Value = vaMatchResultsData
    End With
    wsResults.UsedRange.Resize(1).Font.Bold = True
    wsResults.Cells.EntireColumn.AutoFit
    
End If

WB.Close savechanges:=False

Application.ScreenUpdating = True

End Sub

Function CollectionKeyExists(coll As Collection, key As String) As Boolean

    On Error GoTo EH

    IsObject (coll.Item(key))
    
    CollectionKeyExists = True
EH:
End Function

Private Function GetTerminalName(ByVal Filenamex As Variant) As String
'*****************************************************************
'** Return final element of filename (excluding file extension) **
'*****************************************************************
Dim lUB As Long

Dim saSplit() As String
Dim saSplit2() As String

saSplit = Split(Filenamex, Delimiter:=Application.PathSeparator)
lUB = UBound(saSplit)
saSplit2 = Split(saSplit(lUB), ".")
GetTerminalName = saSplit2(0)
End Function

al_b_cnu · Apr 15, 2024

Hi Greg, I've been thinking about this, You really need to filter on Quantity as well as Brand. I've amended the code to compare the DB quantity against the quantity extracted from the reseller Title field (I've assumed it is format nnnxx or nnn xx (e.g. 500l or 500 l)
Here's the new parameter sheet which allows you to switch on/off the quantity filter:

GetBarcodes V3.xlsm

A

B

C

1

Keyword

Value

Comment

2

Group Heading

Brand

Heading in Database and Reseller files of column which MUST match exactly for an entry to be a candidate for comparison

3

Match Heading

Title

Heading in Database and Reseller files of column to be fuzzy matched

4

DB Quantity

Quantity

Heading in Database of column containing quantity

5

DB Barcode

Barcode

Heading in Database of column containing Barcode

6

# Matches per Entry

5

Return the best 5 matching barcodes

7

Min % Match

5%

Ignore any matches in 'Title' column below 5%

8

Match Algorithm

2

Set to '2' to match pairs then triplets then quads etc, or '4' for Levenstein match. Algorithm 4 is more accurate but slower.

9

Show DB Title

Yes

Data item in Database to be shown in results Value must start with 'Y' to be included

10

Show DB Quantity

Yes

Data item in Database to be shown in results Value must start with 'Y' to be included

11

Compare Quantity

Yes

Perform comparison of quantity obtained in Reseller Title field with Database quantity.

Parameters

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A:C	Expression	=$A1<>""	text	NO

Here's the results with "Compare Quantity" off

Book11

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

1

Brand

Title

Quantity

Barcode

Barcode #1

#1 % Match

#1 DB title

#1 DB Quantity

Barcode #2

#2 % Match

#2 DB title

#2 DB Quantity

Barcode #3

#3 % Match

#3 DB title

#3 DB Quantity

Barcode #4

#4 % Match

#4 DB title

#4 DB Quantity

Barcode #5

#5 % Match

#5 DB title

#5 DB Quantity

2

GARNIER

Rulldeo.GARNIER Action Control 50ml

50ml

3600542475112

58.78%

Rulldeodorant Mineral Action Control, GARNIER, 50 ml

50ml

3600542475235

55.73%

Deodorant Roller Action Control Clinical, GARNIER, 50 ml

50ml

3600540801548

48.85%

Deodorant Action Control, GARNIER, 150 ml

150ml

3600542475174

44.27%

Rulldeodorant Action Thermic Women, GARNIER, 50 ml

50ml

3600542475136

41.98%

Rulldeodorant Black-White-Color naistele, GARNIER, 50 ml

50ml

3

Coca-Cola

Soft Drink COCA-COLA Zero 2L

2l

5449000131843

100.00%

Coca-Cola Zero 2L

2l

4743050000045

88.57%

Coca-Cola 2L

2l

5000112651379

88.46%

Coca-Cola Zero 1L

1l

5000112651300

80.00%

Coca-Cola 1L

1l

5449000131805

67.14%

COCA-COLA ZERO 330 ML

330ml

4

FELIX

Magushapu kaste ananassiga FELIX 500g

500g

4750022504098

49.30%

Felix Sweet and sour kaste ananassiga 500 g

500g

4740029048909

42.86%

Felix Wrapikaste 220g

220g

4740029048923

38.16%

Felix Kartulikaste 220g

220g

4750022505118

38.10%

Pastakaste, FELIX, 500 g

500g

4750022510297

37.93%

Mangokaste, FELIX, 500 mg

500mg

5

Colgate

COLGATE HAMBAPASTA TRIPLE ACTION 75ML

75ml

6920354835971

66.20%

Hambapasta Triple Action, COLGATE, 75 ml

75ml

8718951265738

50.00%

Colgate hambapasta lastele kids 3-5a 50ml

50ml

8718951227187

46.48%

Hambapasta Total Advanced Visible Proof, COLGATE, 75 ml

75ml

6920354836091

45.77%

Hambapasta Cavity Protection Whitening, COLGATE, 75 ml

75ml

8718951131606

45.07%

Hambapasta Natural Extracts Ultimate Fresh Lemon, COLGATE, 75 ml

75ml

Reseller 3

As opposed to WITH the quantity filter:

Book12

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

1

Brand

Title

Quantity

Barcode

Barcode #1

#1 % Match

#1 DB title

#1 DB Quantity

Barcode #2

#2 % Match

#2 DB title

#2 DB Quantity

Barcode #3

#3 % Match

#3 DB title

#3 DB Quantity

Barcode #4

#4 % Match

#4 DB title

#4 DB Quantity

Barcode #5

#5 % Match

#5 DB title

#5 DB Quantity

2

GARNIER

Rulldeo.GARNIER Action Control 50ml

50ml

3600542475112

58.78%

Rulldeodorant Mineral Action Control, GARNIER, 50 ml

50ml

3600542475235

55.73%

Deodorant Roller Action Control Clinical, GARNIER, 50 ml

50ml

3600542475174

44.27%

Rulldeodorant Action Thermic Women, GARNIER, 50 ml

50ml

3600542475136

41.98%

Rulldeodorant Black-White-Color naistele, GARNIER, 50 ml

50ml

3600542475273

41.98%

Rulldeodorant Mineral BWC, Clean Cotton, naistele, GARNIER, 50 ml

50ml

3

Coca-Cola

Soft Drink COCA-COLA Zero 2L

2l

5449000131843

100.00%

Coca-Cola Zero 2L

2l

4743050000045

88.57%

Coca-Cola 2L

2l

5000112614497

35.64%

Karastusjook Coca-Cola, COCA-COLA, 2 L

2l

5000112614282

20.79%

Elektriline hambahari lastele Batman, COLGATE, 1 tk

2l

4

FELIX

Magushapu kaste ananassiga FELIX 500g

500g

4750022504098

49.30%

Felix Sweet and sour kaste ananassiga 500 g

500g

4750022505118

38.10%

Pastakaste, FELIX, 500 g

500g

4750022519115

33.80%

Hiina kaste (poolmagus), FELIX, 500 g

500g

4750022503114

30.97%

Terav Hiina kaste, FELIX, 500 g

500g

4740029606345

30.77%

Tomatiketšup, FELIX, 500 g

500g

5

Colgate

COLGATE HAMBAPASTA TRIPLE ACTION 75ML

75ml

6920354835971

66.20%

Hambapasta Triple Action, COLGATE, 75 ml

75ml

8718951227187

46.48%

Hambapasta Total Advanced Visible Proof, COLGATE, 75 ml

75ml

6920354836091

45.77%

Hambapasta Cavity Protection Whitening, COLGATE, 75 ml

75ml

8718951131606

45.07%

Hambapasta Natural Extracts Ultimate Fresh Lemon, COLGATE, 75 ml

75ml

6920354829406

44.37%

Colgate Total Charcoal 75ml hambapasta

75ml

Reseller 3

Here's the amended code:

VBA Code:

Option Explicit

Type Params
    GroupHeading As String
    MatchHeading As String
    MatchesCount As Long
    MinPercent As Single
    Algorithm As Single
    DBQuantity As String
    DBBarcode As String
    ShowTitle As Boolean
    ShowQty As Boolean
    CompareQty As Boolean
End Type
Dim mudtParameters As Params

Type BrandBounds
    BrandName As String
    BrandLB As Long
    BrandUB As Long
End Type

Dim mcolBrandbounds As Collection

Type DatabaseData
    Brand As String
    Title As String
    Qty As String
    BarCode As String
End Type
Dim mudtDatabase() As DatabaseData

Type BarCodeMatches
    BarCode As String
    BrandPercent As Single
    MatchText As String
    Qty As String
End Type

Sub click_GetBarcodes()

Dim lUB As Long
Dim lLastUB  As Long
Dim lRow As Long

Dim saCurName() As String
Dim sCurTerminalName As String
Dim sPrevBrand As String
Dim sCurBrand As String

Dim vCurFilename As Variant
Dim vResellerFiles As Variant
Dim vaDatabase As Variant
Dim vaBrandLimits As Variant
Dim vaDicBrandItem As Variant
Dim vaBrandBounds As Variant

Dim udtBrandBound As BrandBounds

Dim WBcur As Workbook
Dim wbResults As Workbook

Dim wsDB As Worksheet
Dim wsCur As Worksheet

'MsgBox Application.OperatingSystem

mudtParameters = GetParameters()

Application.DisplayAlerts = False

'*********************************
'**Get database data into array **
'*********************************
Set wsDB = ThisWorkbook.Sheets("Database")
With wsDB.UsedRange
    vaDatabase = wsDB.Range("A1").Resize(.Rows.Count, .Columns.Count).Value
End With

'*************************************************************************************
'** Set up Brands bounds collection                                              **
'** Note that the database entries MUST be sorted into ascending brand sequence!    **
'*************************************************************************************
Set mcolBrandbounds = New Collection
lUB = 0
sPrevBrand = ""
ReDim vaBrandBounds(1 To 3)
For lRow = 2 To UBound(vaDatabase, 1)
    sCurBrand = NormaliseName(vaDatabase(lRow, 1))
    If sCurBrand <> "" Then
        If sCurBrand < sPrevBrand Then
'            MsgBox prompt:="Database not sorted into ascending Brand sequence at row " & lRow, _
'                    Buttons:=vbOKOnly + vbCritical, _
'                    Title:="Database Sequence Error"
'            Set mcolBrandbounds = Nothing
'            Exit Sub

        ElseIf sCurBrand = sPrevBrand Then
            '** Update End row for current brand
            vaBrandBounds(3) = lRow
        Else
            '** Here if new brand entry row encountered **
            If sPrevBrand <> "" Then
                If CollectionKeyExists(coll:=mcolBrandbounds, key:=sPrevBrand) Then
                    MsgBox prompt:="Brand key " & sPrevBrand & " at row " & lRow & " already exists", _
                            Buttons:=vbOKOnly + vbCritical, _
                            Title:="Database sequence error"
                    Set mcolBrandbounds = Nothing
                    Exit Sub
                End If
                On Error Resume Next
                mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds
                On Error GoTo 0
            End If
            vaBrandBounds(1) = sCurBrand
            vaBrandBounds(2) = lRow
            vaBrandBounds(3) = lRow
           
            sPrevBrand = sCurBrand
           
        End If
    End If
Next lRow
On Error Resume Next
mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds        '** Write final entry **
On Error GoTo 0

'**************************************************
'** Store database in the udt array mudtDatabase **
'**************************************************
Call PopulateDatabaseEntries(DBArray:=vaDatabase)

'***********************************
'** Get input reseller file names **
'***********************************
If InStr(1, Application.OperatingSystem, "Windows") = 0 Then
    vResellerFiles = Application.GetOpenFilename(Title:="Please select Reseller Excel file")
Else
    vResellerFiles = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", _
                                                Title:="Please select Reseller Excel file(s)", _
                                                MultiSelect:=True)
    If IsArray(vResellerFiles) = False Then Exit Sub
End If

'****************************
'** Create output workbook **
'****************************
Set wbResults = Nothing
On Error Resume Next
Set wbResults = Workbooks.Add
On Error GoTo 0
If wbResults Is Nothing Then
    If Err.Number > 0 Then
        MsgBox prompt:=Err.Description, _
                Buttons:=vbOKOnly + vbCritical, _
                Title:="Cannot create Results Workbook"
       
    End If
    Exit Sub
End If

'******************************
'** Process Reseller file(s) **
'******************************
If IsArray(vResellerFiles) Then
    For Each vCurFilename In vResellerFiles
       
        Call ProcessInputFile(DBData:=vaDatabase, _
                              InputFileName:=vCurFilename, _
                              ResultsWB:=wbResults)
       
    Next vCurFilename
Else
        Call ProcessInputFile(DBData:=vaDatabase, _
                          InputFileName:=vResellerFiles, _
                          ResultsWB:=wbResults)
End If

On Error Resume Next
wbResults.Sheets(1).Delete
Set mcolBrandbounds = Nothing
On Error GoTo 0

Application.StatusBar = False

End Sub

Private Sub PopulateDatabaseEntries(ByVal DBArray As Variant)
'************************************
'** Create entries in mudtDataBase **
'************************************
Dim lRow As Long
Dim lCol As Long
Dim lColBrand As Long
Dim lColTitle As Long
Dim lColQty As Long
Dim lColBarCode As Long
Dim lEntriesPtr As Long

Dim sCurHeading As String

For lCol = 1 To UBound(DBArray, 2)
    sCurHeading = NormaliseName(CStr(DBArray(1, lCol)))
    Select Case sCurHeading
        Case NormaliseName(mudtParameters.GroupHeading)
            lColBrand = lCol
        Case NormaliseName(mudtParameters.MatchHeading)
            lColTitle = lCol
        Case NormaliseName(mudtParameters.DBQuantity)
            lColQty = lCol
        Case NormaliseName(mudtParameters.DBBarcode)
            lColBarCode = lCol
    End Select
Next lCol

ReDim mudtDatabase(1 To 1)
lEntriesPtr = 1
mudtDatabase(1).Brand = ""
On Error Resume Next
For lRow = 2 To UBound(DBArray, 1)
    If Trim$(DBArray(lRow, lColBrand)) <> "" Then
        lEntriesPtr = lEntriesPtr + 1
        ReDim Preserve mudtDatabase(1 To lEntriesPtr)
        On Error Resume Next
        mudtDatabase(lEntriesPtr).BarCode = CStr(DBArray(lRow, lColBarCode))
        mudtDatabase(lEntriesPtr).Brand = NormaliseName(DBArray(lRow, lColBrand))
        mudtDatabase(lEntriesPtr).Qty = CStr(DBArray(lRow, lColQty))
        mudtDatabase(lEntriesPtr).Title = CStr(DBArray(lRow, lColTitle))
        On Error GoTo 0
    End If
Next lRow

End Sub

Private Function GetParameters() As Params
'***********************************************
'** Return parameters from sheet 'parameters' **
'***********************************************
Dim lRow As Long
Dim lEndRow As Long

Dim sCurKeyword As String
Dim sCurValue As String

Dim vaParamData As Variant

'** Store parameter data into array **
vaParamData = ThisWorkbook.Sheets("Parameters").Range("A1").CurrentRegion.Resize(, 2).Value

For lRow = 2 To UBound(vaParamData, 1)
    sCurKeyword = LCase$(Replace(vaParamData(lRow, 1), " ", ""))    '** Remove all spaces and convert to lowercase
    Select Case sCurKeyword
        Case ""             '** Ignore empty keyword cells **
           
        Case "groupheading"
            GetParameters.GroupHeading = NormaliseName(vaParamData(lRow, 2))
        Case "matchheading"
            GetParameters.MatchHeading = NormaliseName(vaParamData(lRow, 2))
        Case "#matchesperentry"
            GetParameters.MatchesCount = Val(vaParamData(lRow, 2))
        Case "min%match"
            GetParameters.MinPercent = Val(vaParamData(lRow, 2))
        Case "matchalgorithm"
            GetParameters.Algorithm = Val(vaParamData(lRow, 2))
        Case "dbquantity"
            GetParameters.DBQuantity = CStr(vaParamData(lRow, 2))
        Case "dbbarcode"
            GetParameters.DBBarcode = CStr(vaParamData(lRow, 2))
        Case "showdbtitle"
            GetParameters.ShowTitle = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
        Case "showdbquantity"
            GetParameters.ShowQty = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
        Case "comparequantity"
            GetParameters.CompareQty = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
    End Select
Next lRow

End Function
Private Function NormaliseName(ByVal NameX As String) As String
'*************************************************************************************
'** Remove all but "abcdefghijklmnopqrstuvwxyz0123456789", and convert to lowercase **
'*************************************************************************************
Dim lPtr As Long

Dim sChar As String
Dim sResult As String

For lPtr = 1 To Len(NameX)
    sChar = LCase$(Mid$(NameX, lPtr, 1))
    If InStr("abcdefghijklmnopqrstuvwxyz0123456789", sChar) > 0 Then sResult = sResult & sChar
Next lPtr
NormaliseName = sResult
End Function

Private Sub ProcessInputFile(ByVal DBData As Variant, _
                             ByVal InputFileName As Variant, _
                             ByRef ResultsWB As Workbook)

Dim lCol As Long
Dim lRow As Long
Dim lPtr As Long
Dim lMustMatchCol As Long
Dim lMatchCol As Long
Dim lLB As Long
Dim lUB As Long
Dim lDBRow As Long
Dim lPtr1 As Long
Dim lPtr2 As Long
Dim lSheetCount As Long
Dim lResultsColumnCount As Long
Dim lMatchQty As Long

Dim sDBQty As String
Dim sResellerTitleTemp As String
Dim sCurHeading As String
Dim sTerminalName As String
Dim sCurResellerBrand As String
Dim sCurResellerTitle As String
Dim sCurDBTitle As String

Dim sngCurMatchPercent As Single

Dim udtBarCodeMatches() As BarCodeMatches
Dim udtBrandBounds As BrandBounds

Dim vaCurData As Variant
Dim vaMatchResultsData As Variant
Dim vaCurBrandItem As Variant

Dim WB As Workbook

Dim WS As Worksheet
Dim wsResults As Worksheet

lMustMatchCol = 0
lMatchCol = 0

sTerminalName = GetTerminalName(InputFileName)

Application.StatusBar = "Processing " & sTerminalName
Application.ScreenUpdating = False

On Error Resume Next
Set WB = Nothing
Set WB = Workbooks.Open(Filename:=InputFileName, _
                        UpdateLinks:=True, _
                        ReadOnly:=True, _
                        corruptload:=xlRepairFile)
If Err.Number > 0 Then
    MsgBox prompt:=Err.Description, Buttons:=vbOKOnly + vbCritical, Title:="Unable to open file " & sTerminalName
End If
On Error GoTo 0
If WB Is Nothing Then Exit Sub

Set WS = WB.Sheets(1)
With WS.UsedRange
    vaCurData = WS.Range("A1").Resize(.Rows.Count, .Columns.Count).Value                '** Get input Reseller data
End With

'** Initialise results array **
lResultsColumnCount = 2
If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
ReDim vaMatchResultsData(1 To UBound(vaCurData, 1), 1 To mudtParameters.MatchesCount * lResultsColumnCount) '** set size of array for Results
For lCol = 1 To mudtParameters.MatchesCount
    lPtr = ((lCol - 1) * lResultsColumnCount) + 1
    vaMatchResultsData(1, lPtr) = "Barcode #" & lCol
    vaMatchResultsData(1, lPtr + 1) = "#" & lCol & " % Match"
    lPtr1 = lPtr + 1
    If mudtParameters.ShowTitle = True Then
        lPtr1 = lPtr1 + 1
        vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB " & mudtParameters.MatchHeading
    End If
    If mudtParameters.ShowQty = True Then
        lPtr1 = lPtr1 + 1
        vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB Quantity"
    End If
Next lCol

'** Check that we have the 2 required heading columns in row 1**
For lCol = 1 To UBound(vaCurData, 2)
    sCurHeading = NormaliseName(CStr(vaCurData(1, lCol)))
    If sCurHeading = mudtParameters.GroupHeading Then lMustMatchCol = lCol
    If sCurHeading = mudtParameters.MatchHeading Then lMatchCol = lCol
Next lCol
If lMustMatchCol > 0 _
And lMatchCol > 0 Then
    '** Process the reseller **
    lSheetCount = ResultsWB.Worksheets.Count
    Set wsResults = ResultsWB.Sheets.Add(after:=ResultsWB.Sheets(lSheetCount))        '** Add a new worksheet to the results workbook
    On Error Resume Next
    wsResults.Name = sTerminalName              '** set the sheetname to the reseller file terminal name
    On Error GoTo 0
    '** MAIN LOOP **
    For lRow = 2 To UBound(vaCurData, 1)
        With Application
            .ScreenUpdating = True
            .StatusBar = "Processing Reseller file " & sTerminalName & ", row " & lRow & " of " & UBound(vaCurData, 1)
            .ScreenUpdating = False
        End With
        sCurResellerBrand = NormaliseName(vaCurData(lRow, lMustMatchCol))
        sCurResellerTitle = vaCurData(lRow, lMatchCol)

        If CollectionKeyExists(coll:=mcolBrandbounds, key:=sCurResellerBrand) Then
            ReDim vaCurBrandItem(1 To 3)
            vaCurBrandItem = mcolBrandbounds.Item(sCurResellerBrand)
       
            '** Initialise array **
            ReDim udtBarCodeMatches(1 To mudtParameters.MatchesCount + 1)
            For lPtr = 1 To UBound(udtBarCodeMatches)
                With udtBarCodeMatches(lPtr)
                    .BarCode = ""
                    .BrandPercent = 0
                    .MatchText = ""
                    .Qty = ""
                End With
            Next lPtr
           
            sCurResellerTitle = vaCurData(lRow, lMatchCol)
            For lDBRow = vaCurBrandItem(2) To vaCurBrandItem(3)
                If mudtParameters.CompareQty = True Then
                    sResellerTitleTemp = LCase$(sCurResellerTitle) & " "
                    lMatchQty = InStr(1, sResellerTitleTemp, " " & LCase$(mudtDatabase(lDBRow).Qty) & " ")
                    If lMatchQty = 0 Then
                        sDBQty = LCase$(PadQuantity(mudtDatabase(lDBRow).Qty))
                        lMatchQty = InStr(1, sResellerTitleTemp, " " & sDBQty & " ")
                    End If
                    If lMatchQty = 0 Then
                        sngCurMatchPercent = 0
                    Else
                        sngCurMatchPercent = FuzzyPercent(String1:=sCurResellerTitle, _
                                                          String2:=mudtDatabase(lDBRow).Title, _
                                                          Algorithm:=mudtParameters.Algorithm, _
                                                          Normalised:=False)
                    End If
                Else
                    sngCurMatchPercent = FuzzyPercent(String1:=sCurResellerTitle, _
                                                      String2:=mudtDatabase(lDBRow).Title, _
                                                      Algorithm:=mudtParameters.Algorithm, _
                                                      Normalised:=False)
                End If
                If sngCurMatchPercent >= mudtParameters.MinPercent Then
                    For lPtr1 = 1 To mudtParameters.MatchesCount
                        If sngCurMatchPercent > udtBarCodeMatches(lPtr1).BrandPercent Then
                            For lPtr2 = mudtParameters.MatchesCount - 1 To lPtr1 Step -1
                                If udtBarCodeMatches(lPtr2).BrandPercent <> 0 Then
                                    With udtBarCodeMatches(lPtr2 + 1)
                                        .BarCode = udtBarCodeMatches(lPtr2).BarCode
                                        .BrandPercent = udtBarCodeMatches(lPtr2).BrandPercent
                                        .MatchText = udtBarCodeMatches(lPtr2).MatchText
                                        .Qty = udtBarCodeMatches(lPtr2).Qty
                                    End With
                                End If
                            Next lPtr2
                            With udtBarCodeMatches(lPtr1)
                                .BarCode = mudtDatabase(lDBRow).BarCode
                                .BrandPercent = sngCurMatchPercent
                                .MatchText = mudtDatabase(lDBRow).Title
                                .Qty = mudtDatabase(lDBRow).Qty
                            End With
                            Exit For
                        End If
                    Next lPtr1
                End If
            Next lDBRow
            For lCol = 1 To mudtParameters.MatchesCount
                If udtBarCodeMatches(lCol).BrandPercent > 0 Then
                    lPtr = ((lCol - 1) * lResultsColumnCount) + 1
                    vaMatchResultsData(lRow, lPtr) = "'" & udtBarCodeMatches(lCol).BarCode
                    vaMatchResultsData(lRow, lPtr + 1) = udtBarCodeMatches(lCol).BrandPercent
                    lPtr1 = lPtr + 1
                    If mudtParameters.ShowTitle = True Then
                        lPtr1 = lPtr1 + 1
                        vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).MatchText
                    End If
                    If mudtParameters.ShowQty = True Then
                        lPtr1 = lPtr1 + 1
                        vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).Qty
                    End If
                End If
            Next lCol
        End If
    Next lRow
   
    '** Store results into worksheet **
    wsResults.Range("A1").Resize(UBound(vaCurData, 1), UBound(vaCurData, 2)).Value = vaCurData
    lResultsColumnCount = 2
    If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
    If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
    With wsResults.Range("A1").Offset(, UBound(vaCurData, 2))
        For lCol = 1 To mudtParameters.MatchesCount
            lPtr = ((lCol - 1) * lResultsColumnCount)
            With .Offset(, lPtr + 1).Resize(wsResults.Rows.Count, 1)
                .NumberFormat = "0.00%"
                .HorizontalAlignment = xlLeft
            End With
        Next lCol
        .Resize(UBound(vaMatchResultsData, 1), UBound(vaMatchResultsData, 2)).Value = vaMatchResultsData
    End With
    wsResults.UsedRange.Resize(1).Font.Bold = True
    wsResults.Cells.EntireColumn.AutoFit
   
End If

WB.Close savechanges:=False

Application.ScreenUpdating = True

End Sub
Private Function PadQuantity(ByVal Quantity As String) As String
'***********************************************************
'** Insert a space between numbers and text in a quantity **
'***********************************************************
Dim lPtr As Long

Dim sChar As String
Dim sLeft As String
Dim sRight As String

sLeft = ""
sRight = ""
PadQuantity = Quantity
For lPtr = 1 To Len(Quantity)
    sChar = Mid$(Quantity, lPtr, 1)
    If InStr("0123456789", sChar) = 0 Then
        If lPtr > 1 Then sLeft = Left$(Quantity, lPtr - 1)
        If lPtr < Len(Quantity) Then sRight = Mid$(Quantity, lPtr)
        PadQuantity = sLeft & " " & sRight
        Exit For
    End If
Next lPtr
End Function
Function CollectionKeyExists(coll As Collection, key As String) As Boolean

    On Error GoTo EH

    IsObject (coll.Item(key))
   
    CollectionKeyExists = True
EH:
End Function

Private Function GetTerminalName(ByVal Filenamex As Variant) As String
'*****************************************************************
'** Return final element of filename (excluding file extension) **
'*****************************************************************
Dim lUB As Long

Dim saSplit() As String
Dim saSplit2() As String

saSplit = Split(Filenamex, Delimiter:=Application.PathSeparator)
lUB = UBound(saSplit)
saSplit2 = Split(saSplit(lUB), ".")
GetTerminalName = saSplit2(0)
End Function

al_b_cnu · Apr 15, 2024

and here's the corrected code:

VBA Code:

Option Explicit

Type Params
    GroupHeading As String
    MatchHeading As String
    MatchesCount As Long
    MinPercent As Single
    Algorithm As Single
    DBQuantity As String
    DBBarcode As String
    ShowTitle As Boolean
    ShowQty As Boolean
    CompareQty As Boolean
End Type
Dim mudtParameters As Params

Type BrandBounds
    BrandName As String
    BrandLB As Long
    BrandUB As Long
End Type

Dim mcolBrandbounds As Collection

Type DatabaseData
    Brand As String
    Title As String
    Qty As String
    BarCode As String
End Type
Dim mudtDatabase() As DatabaseData

Type BarCodeMatches
    BarCode As String
    BrandPercent As Single
    MatchText As String
    Qty As String
End Type

Sub click_GetBarcodes()

Dim lUB As Long
Dim lLastUB  As Long
Dim lRow As Long

Dim saCurName() As String
Dim sCurTerminalName As String
Dim sPrevBrand As String
Dim sCurBrand As String

Dim vCurFilename As Variant
Dim vResellerFiles As Variant
Dim vaDatabase As Variant
Dim vaBrandLimits As Variant
Dim vaDicBrandItem As Variant
Dim vaBrandBounds As Variant

Dim udtBrandBound As BrandBounds

Dim WBcur As Workbook
Dim wbResults As Workbook

Dim wsDB As Worksheet
Dim wsCur As Worksheet

'MsgBox Application.OperatingSystem

mudtParameters = GetParameters()

Application.DisplayAlerts = False

'*********************************
'**Get database data into array **
'*********************************
Set wsDB = ThisWorkbook.Sheets("Database")
With wsDB.UsedRange
    vaDatabase = wsDB.Range("A1").Resize(.Rows.Count, .Columns.Count).Value
End With

'*************************************************************************************
'** Set up Brands bounds collection                                              **
'** Note that the database entries MUST be sorted into ascending brand sequence!    **
'*************************************************************************************
Set mcolBrandbounds = New Collection
lUB = 0
sPrevBrand = ""
ReDim vaBrandBounds(1 To 3)
For lRow = 2 To UBound(vaDatabase, 1)
    sCurBrand = NormaliseName(vaDatabase(lRow, 1))
    If sCurBrand <> "" Then
        If sCurBrand < sPrevBrand Then
'            MsgBox prompt:="Database not sorted into ascending Brand sequence at row " & lRow, _
'                    Buttons:=vbOKOnly + vbCritical, _
'                    Title:="Database Sequence Error"
'            Set mcolBrandbounds = Nothing
'            Exit Sub

        ElseIf sCurBrand = sPrevBrand Then
            '** Update End row for current brand
            vaBrandBounds(3) = lRow
        Else
            '** Here if new brand entry row encountered **
            If sPrevBrand <> "" Then
                If CollectionKeyExists(coll:=mcolBrandbounds, key:=sPrevBrand) Then
                    MsgBox prompt:="Brand key " & sPrevBrand & " at row " & lRow & " already exists", _
                            Buttons:=vbOKOnly + vbCritical, _
                            Title:="Database sequence error"
                    Set mcolBrandbounds = Nothing
                    Exit Sub
                End If
                On Error Resume Next
                mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds
                On Error GoTo 0
            End If
            vaBrandBounds(1) = sCurBrand
            vaBrandBounds(2) = lRow
            vaBrandBounds(3) = lRow
            
            sPrevBrand = sCurBrand
            
        End If
    End If
Next lRow
On Error Resume Next
mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds        '** Write final entry **
On Error GoTo 0

'**************************************************
'** Store database in the udt array mudtDatabase **
'**************************************************
Call PopulateDatabaseEntries(DBArray:=vaDatabase)

'***********************************
'** Get input reseller file names **
'***********************************
If InStr(1, Application.OperatingSystem, "Windows") = 0 Then
    vResellerFiles = Application.GetOpenFilename(Title:="Please select Reseller Excel file")
Else
    vResellerFiles = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", _
                                                Title:="Please select Reseller Excel file(s)", _
                                                MultiSelect:=True)
    If IsArray(vResellerFiles) = False Then Exit Sub
End If

'****************************
'** Create output workbook **
'****************************
Set wbResults = Nothing
On Error Resume Next
Set wbResults = Workbooks.Add
On Error GoTo 0
If wbResults Is Nothing Then
    If Err.Number > 0 Then
        MsgBox prompt:=Err.Description, _
                Buttons:=vbOKOnly + vbCritical, _
                Title:="Cannot create Results Workbook"
        
    End If
    Exit Sub
End If

'******************************
'** Process Reseller file(s) **
'******************************
If IsArray(vResellerFiles) Then
    For Each vCurFilename In vResellerFiles
        
        Call ProcessInputFile(DBData:=vaDatabase, _
                              InputFileName:=vCurFilename, _
                              ResultsWB:=wbResults)
        
    Next vCurFilename
Else
        Call ProcessInputFile(DBData:=vaDatabase, _
                          InputFileName:=vResellerFiles, _
                          ResultsWB:=wbResults)
End If

On Error Resume Next
wbResults.Sheets(1).Delete
Set mcolBrandbounds = Nothing
On Error GoTo 0

Application.StatusBar = False

End Sub

Private Sub PopulateDatabaseEntries(ByVal DBArray As Variant)
'************************************
'** Create entries in mudtDataBase **
'************************************
Dim lRow As Long
Dim lCol As Long
Dim lColBrand As Long
Dim lColTitle As Long
Dim lColQty As Long
Dim lColBarCode As Long
Dim lEntriesPtr As Long

Dim sCurHeading As String

For lCol = 1 To UBound(DBArray, 2)
    sCurHeading = NormaliseName(CStr(DBArray(1, lCol)))
    Select Case sCurHeading
        Case NormaliseName(mudtParameters.GroupHeading)
            lColBrand = lCol
        Case NormaliseName(mudtParameters.MatchHeading)
            lColTitle = lCol
        Case NormaliseName(mudtParameters.DBQuantity)
            lColQty = lCol
        Case NormaliseName(mudtParameters.DBBarcode)
            lColBarCode = lCol
    End Select
Next lCol

ReDim mudtDatabase(1 To 1)
lEntriesPtr = 1
mudtDatabase(1).Brand = ""
On Error Resume Next
For lRow = 2 To UBound(DBArray, 1)
    If Trim$(DBArray(lRow, lColBrand)) <> "" Then
        lEntriesPtr = lEntriesPtr + 1
        ReDim Preserve mudtDatabase(1 To lEntriesPtr)
        On Error Resume Next
        mudtDatabase(lEntriesPtr).BarCode = CStr(DBArray(lRow, lColBarCode))
        mudtDatabase(lEntriesPtr).Brand = NormaliseName(DBArray(lRow, lColBrand))
        mudtDatabase(lEntriesPtr).Qty = CStr(DBArray(lRow, lColQty))
        mudtDatabase(lEntriesPtr).Title = CStr(DBArray(lRow, lColTitle))
        On Error GoTo 0
    End If
Next lRow

End Sub

Private Function GetParameters() As Params
'***********************************************
'** Return parameters from sheet 'parameters' **
'***********************************************
Dim lRow As Long
Dim lEndRow As Long

Dim sCurKeyword As String
Dim sCurValue As String

Dim vaParamData As Variant

'** Store parameter data into array **
vaParamData = ThisWorkbook.Sheets("Parameters").Range("A1").CurrentRegion.Resize(, 2).Value

For lRow = 2 To UBound(vaParamData, 1)
    sCurKeyword = LCase$(Replace(vaParamData(lRow, 1), " ", ""))    '** Remove all spaces and convert to lowercase
    Select Case sCurKeyword
        Case ""             '** Ignore empty keyword cells **
            
        Case "groupheading"
            GetParameters.GroupHeading = NormaliseName(vaParamData(lRow, 2))
        Case "matchheading"
            GetParameters.MatchHeading = NormaliseName(vaParamData(lRow, 2))
        Case "#matchesperentry"
            GetParameters.MatchesCount = Val(vaParamData(lRow, 2))
        Case "min%match"
            GetParameters.MinPercent = Val(vaParamData(lRow, 2))
        Case "matchalgorithm"
            GetParameters.Algorithm = Val(vaParamData(lRow, 2))
        Case "dbquantity"
            GetParameters.DBQuantity = CStr(vaParamData(lRow, 2))
        Case "dbbarcode"
            GetParameters.DBBarcode = CStr(vaParamData(lRow, 2))
        Case "showdbtitle"
            GetParameters.ShowTitle = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
        Case "showdbquantity"
            GetParameters.ShowQty = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
        Case "comparequantity"
            GetParameters.CompareQty = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
    End Select
Next lRow

End Function
Private Function NormaliseName(ByVal NameX As String) As String
'*************************************************************************************
'** Remove all but "abcdefghijklmnopqrstuvwxyz0123456789", and convert to lowercase **
'*************************************************************************************
Dim lPtr As Long

Dim sChar As String
Dim sResult As String

For lPtr = 1 To Len(NameX)
    sChar = LCase$(Mid$(NameX, lPtr, 1))
    If InStr("abcdefghijklmnopqrstuvwxyz0123456789", sChar) > 0 Then sResult = sResult & sChar
Next lPtr
NormaliseName = sResult
End Function

Private Sub ProcessInputFile(ByVal DBData As Variant, _
                             ByVal InputFileName As Variant, _
                             ByRef ResultsWB As Workbook)

Dim bRecordWanted As Boolean

Dim lCol As Long
Dim lRow As Long
Dim lPtr As Long
Dim lMustMatchCol As Long
Dim lMatchCol As Long
Dim lQuantityCol As Long
Dim lLB As Long
Dim lUB As Long
Dim lDBRow As Long
Dim lPtr1 As Long
Dim lPtr2 As Long
Dim lSheetCount As Long
Dim lResultsColumnCount As Long
Dim lMatchQty As Long

Dim sDBQty As String
Dim sResellerTitleTemp As String
Dim sCurHeading As String
Dim sTerminalName As String
Dim sCurResellerBrand As String
Dim sCurResellerTitle As String
Dim sCurDBTitle As String

Dim sngCurMatchPercent As Single

Dim udtBarCodeMatches() As BarCodeMatches
Dim udtBrandBounds As BrandBounds

Dim vaCurData As Variant
Dim vaMatchResultsData As Variant
Dim vaCurBrandItem As Variant

Dim WB As Workbook

Dim WS As Worksheet
Dim wsResults As Worksheet

lMustMatchCol = 0
lMatchCol = 0
lQuantityCol = 0

sTerminalName = GetTerminalName(InputFileName)

Application.StatusBar = "Processing " & sTerminalName
Application.ScreenUpdating = False

On Error Resume Next
Set WB = Nothing
Set WB = Workbooks.Open(Filename:=InputFileName, _
                        UpdateLinks:=True, _
                        ReadOnly:=True, _
                        corruptload:=xlRepairFile)
If Err.Number > 0 Then
    MsgBox prompt:=Err.Description, Buttons:=vbOKOnly + vbCritical, Title:="Unable to open file " & sTerminalName
End If
On Error GoTo 0
If WB Is Nothing Then Exit Sub

Set WS = WB.Sheets(1)
With WS.UsedRange
    vaCurData = WS.Range("A1").Resize(.Rows.Count, .Columns.Count).Value                '** Get input Reseller data
End With

'** Initialise results array **
lResultsColumnCount = 2
If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
ReDim vaMatchResultsData(1 To UBound(vaCurData, 1), 1 To mudtParameters.MatchesCount * lResultsColumnCount) '** set size of array for Results
For lCol = 1 To mudtParameters.MatchesCount
    lPtr = ((lCol - 1) * lResultsColumnCount) + 1
    vaMatchResultsData(1, lPtr) = "Barcode #" & lCol
    vaMatchResultsData(1, lPtr + 1) = "#" & lCol & " % Match"
    lPtr1 = lPtr + 1
    If mudtParameters.ShowTitle = True Then
        lPtr1 = lPtr1 + 1
        vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB " & mudtParameters.MatchHeading
    End If
    If mudtParameters.ShowQty = True Then
        lPtr1 = lPtr1 + 1
        vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB Quantity"
    End If
Next lCol

'** Check that we have the 2 required heading columns in row 1**
For lCol = 1 To UBound(vaCurData, 2)
    sCurHeading = NormaliseName(CStr(vaCurData(1, lCol)))
    If sCurHeading = mudtParameters.GroupHeading Then lMustMatchCol = lCol
    If sCurHeading = mudtParameters.MatchHeading Then lMatchCol = lCol
    If sCurHeading = LCase$(mudtParameters.DBQuantity) Then lQuantityCol = lCol
Next lCol
If lMustMatchCol > 0 _
And lMatchCol > 0 Then
    '** Process the reseller **
    lSheetCount = ResultsWB.Worksheets.Count
    Set wsResults = ResultsWB.Sheets.Add(after:=ResultsWB.Sheets(lSheetCount))        '** Add a new worksheet to the results workbook
    On Error Resume Next
    wsResults.Name = sTerminalName              '** set the sheetname to the reseller file terminal name
    On Error GoTo 0
    '** MAIN LOOP **
    For lRow = 2 To UBound(vaCurData, 1)
        With Application
            .ScreenUpdating = True
            .StatusBar = "Processing Reseller file " & sTerminalName & ", row " & lRow & " of " & UBound(vaCurData, 1)
            .ScreenUpdating = False
        End With
        sCurResellerBrand = NormaliseName(vaCurData(lRow, lMustMatchCol))
        sCurResellerTitle = vaCurData(lRow, lMatchCol)

        If CollectionKeyExists(coll:=mcolBrandbounds, key:=sCurResellerBrand) Then
            ReDim vaCurBrandItem(1 To 3)
            vaCurBrandItem = mcolBrandbounds.Item(sCurResellerBrand)
        
            '** Initialise array **
            ReDim udtBarCodeMatches(1 To mudtParameters.MatchesCount + 1)
            For lPtr = 1 To UBound(udtBarCodeMatches)
                With udtBarCodeMatches(lPtr)
                    .BarCode = ""
                    .BrandPercent = 0
                    .MatchText = ""
                    .Qty = ""
                End With
            Next lPtr
            
            sCurResellerTitle = vaCurData(lRow, lMatchCol)
            For lDBRow = vaCurBrandItem(2) To vaCurBrandItem(3)
                
                bRecordWanted = True
                If mudtParameters.CompareQty = True Then
                    bRecordWanted = LCase$(mudtDatabase(lDBRow).Qty) = LCase$(Trim$(vaCurData(lRow, lQuantityCol)))
                End If
                sngCurMatchPercent = 0
                If bRecordWanted = True Then
                    sngCurMatchPercent = FuzzyPercent(String1:=sCurResellerTitle, _
                                                      String2:=mudtDatabase(lDBRow).Title, _
                                                      Algorithm:=mudtParameters.Algorithm, _
                                                      Normalised:=False)
                End If
                If sngCurMatchPercent >= mudtParameters.MinPercent Then
                    For lPtr1 = 1 To mudtParameters.MatchesCount
                        If sngCurMatchPercent > udtBarCodeMatches(lPtr1).BrandPercent Then
                            For lPtr2 = mudtParameters.MatchesCount - 1 To lPtr1 Step -1
                                If udtBarCodeMatches(lPtr2).BrandPercent <> 0 Then
                                    With udtBarCodeMatches(lPtr2 + 1)
                                        .BarCode = udtBarCodeMatches(lPtr2).BarCode
                                        .BrandPercent = udtBarCodeMatches(lPtr2).BrandPercent
                                        .MatchText = udtBarCodeMatches(lPtr2).MatchText
                                        .Qty = udtBarCodeMatches(lPtr2).Qty
                                    End With
                                End If
                            Next lPtr2
                            With udtBarCodeMatches(lPtr1)
                                .BarCode = mudtDatabase(lDBRow).BarCode
                                .BrandPercent = sngCurMatchPercent
                                .MatchText = mudtDatabase(lDBRow).Title
                                .Qty = mudtDatabase(lDBRow).Qty
                            End With
                            Exit For
                        End If
                    Next lPtr1
                End If
            Next lDBRow
            For lCol = 1 To mudtParameters.MatchesCount
                If udtBarCodeMatches(lCol).BrandPercent > 0 Then
                    lPtr = ((lCol - 1) * lResultsColumnCount) + 1
                    vaMatchResultsData(lRow, lPtr) = "'" & udtBarCodeMatches(lCol).BarCode
                    vaMatchResultsData(lRow, lPtr + 1) = udtBarCodeMatches(lCol).BrandPercent
                    lPtr1 = lPtr + 1
                    If mudtParameters.ShowTitle = True Then
                        lPtr1 = lPtr1 + 1
                        vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).MatchText
                    End If
                    If mudtParameters.ShowQty = True Then
                        lPtr1 = lPtr1 + 1
                        vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).Qty
                    End If
                End If
            Next lCol
        End If
    Next lRow
    
    '** Store results into worksheet **
    wsResults.Range("A1").Resize(UBound(vaCurData, 1), UBound(vaCurData, 2)).Value = vaCurData
    lResultsColumnCount = 2
    If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
    If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
    With wsResults.Range("A1").Offset(, UBound(vaCurData, 2))
        For lCol = 1 To mudtParameters.MatchesCount
            lPtr = ((lCol - 1) * lResultsColumnCount)
            With .Offset(, lPtr + 1).Resize(wsResults.Rows.Count, 1)
                .NumberFormat = "0.00%"
                .HorizontalAlignment = xlLeft
            End With
        Next lCol
        .Resize(UBound(vaMatchResultsData, 1), UBound(vaMatchResultsData, 2)).Value = vaMatchResultsData
    End With
    wsResults.UsedRange.Resize(1).Font.Bold = True
    wsResults.Cells.EntireColumn.AutoFit
    
End If

WB.Close savechanges:=False

Application.ScreenUpdating = True

End Sub

Function CollectionKeyExists(coll As Collection, key As String) As Boolean

    On Error GoTo EH

    IsObject (coll.Item(key))
    
    CollectionKeyExists = True
EH:
End Function

Private Function GetTerminalName(ByVal Filenamex As Variant) As String
'*****************************************************************
'** Return final element of filename (excluding file extension) **
'*****************************************************************
Dim lUB As Long

Dim saSplit() As String
Dim saSplit2() As String

saSplit = Split(Filenamex, Delimiter:=Application.PathSeparator)
lUB = UBound(saSplit)
saSplit2 = Split(saSplit(lUB), ".")
GetTerminalName = saSplit2(0)
End Function

Sonny7 · Apr 15, 2024

Hi Alan,
I've tried your previous update with the quantity and you are definitly right the quantities will be of big help

However, it seems something is a bit strange, maybe you can explain.
When I ran the script today, I did so with a very large file and the results were quite poor sadly.

But I'm thinking with that the way designed the code it should bring more effective results while it's not?!
Here is an example:

The product in the database:
ALMEDA NATURE CARE - ALMEDA NATURE CARE Dušigeel Nature Care Herbs 500ml - 500ml - 4752050022681

The product to match to import the barcode:
Almeda Nature Care - Dušigeel Almeda Nature Care Herbs 500ml - 500ml

The brand is the same (besides the uppercase), the quantity also and the titles are pretty similar but it returned no result on this one example.
Do you have any idea why? (Actually I did also use the last script you just posted)

I'll update my sheet in my Dropbox if you want to check out.
Note that if you run it with my Reseller_1.xlsx beware, the file is very large and it took the computer over 1h to run it.

So, I did create a Reseller_2.xlsx only with this brand above, this way you can see what could be wrong.

Fuzzy Lookup

Shared with Dropbox

www.dropbox.com

Looking forward to your update on this
Thanks!
Greg

Fuzzy Matching - new version plus explanation

al_b_cnu

Well-known Member

al_b_cnu

Well-known Member

Sonny7

New Member

al_b_cnu

Well-known Member

Sonny7

New Member

al_b_cnu

Well-known Member

Sonny7

New Member

al_b_cnu

Well-known Member

al_b_cnu

Well-known Member

al_b_cnu

Well-known Member

Sonny7

New Member

Fuzzy Lookup

Similar threads

Share this page

Fuzzy Matching - new version plus explanation

Well-known Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

New Member

Well-known Member

Well-known Member

Well-known Member

New Member

Similar threads

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock