Fuzzy Matching - new version plus explanation

al_b_cnu

Well-known Member
Joined
Jul 18, 2003
Messages
4,546
It has been a while since I originally posted my Fuzzy matching UDF’s on the board, and several variants have appeared subsequently.

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

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


... Continued ...
 
Hi Greg,
There was an issue in that you have some "funny" brandnames, e.g. "-" ,"%", "8*4" and also you have brands "7 HEAVEN" and "7HEAVEN". The code "normalises" the brand name by removing anything other than alphanumerics and converts to lower case in order to form a search key. I've amended this to be just lowercase.
This is the result I now get:
Book1
BCDEFGHIJKLMNOP
1TitleQuantityBarcode #1#1 % Match#1 DB title#1 DB QuantityBarcode #2#2 % Match#2 DB title#2 DB QuantityBarcode #3#3 % Match#3 DB title#3 DB Quantity
2Dušigeel Almeda Nature Care Berries 750ml750ml475205002264361.87%ALMEDA NATURE CARE Dušigeel meestele Nature Care Bergamot 750ml750ml475205002266758.75%ALMEDA NATURE CARE Dušigeel Nature Care Citrus 750ml750ml475205002267457.50%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 750ml750ml
3Dušigeel Almeda Nature Care Citrus 750ml750ml475205002266776.58%ALMEDA NATURE CARE Dušigeel Nature Care Citrus 750ml750ml475205002264358.86%ALMEDA NATURE CARE Dušigeel meestele Nature Care Bergamot 750ml750ml475205002267458.86%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 750ml750ml
4Dušigeel Almeda Nature Care Coconut & Almond 250ml250ml475205002275976.33%ALMEDA NATURE CARE Dušigeel Nature Care Coconut & Almond 250ml250ml475205002274246.86%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 250ml250ml475205002272845.89%ALMEDA NATURE CARE Dušigeel Nature Care Herbs 250ml250ml
5Dušigeel Almeda Nature Care Coconut & Almond 500ml500ml475205002271176.33%ALMEDA NATURE CARE Dušigeel Nature Care Coconut & Almond 500ml500ml475205002270446.86%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 500ml500ml475205002268145.89%ALMEDA NATURE CARE Dušigeel Nature Care Herbs 500ml500ml
6Dušigeel Almeda Nature Care Fruit Mix 250ml250ml475205002274276.47%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 250ml250ml475205002275954.71%ALMEDA NATURE CARE Dušigeel Nature Care Coconut & Almond 250ml250ml475205002272852.35%ALMEDA NATURE CARE Dušigeel Nature Care Herbs 250ml250ml
7Dušigeel Almeda Nature Care Fruit Mix 500ml500ml475205002270476.47%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 500ml500ml475205002271154.71%ALMEDA NATURE CARE Dušigeel Nature Care Coconut & Almond 500ml500ml475205002268152.35%ALMEDA NATURE CARE Dušigeel Nature Care Herbs 500ml500ml
8Dušigeel Almeda Nature Care Green Tea 250ml250ml475205002275955.29%ALMEDA NATURE CARE Dušigeel Nature Care Coconut & Almond 250ml250ml475205002272854.71%ALMEDA NATURE CARE Dušigeel Nature Care Herbs 250ml250ml475205002274254.12%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 250ml250ml
9Dušigeel Almeda Nature Care Green Tea 500ml500ml475205002271155.29%ALMEDA NATURE CARE Dušigeel Nature Care Coconut & Almond 500ml500ml475205002268154.71%ALMEDA NATURE CARE Dušigeel Nature Care Herbs 500ml500ml475205002270454.12%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 500ml500ml
10Dušigeel Almeda Nature Care Herbs 250ml250ml475205002272876.00%ALMEDA NATURE CARE Dušigeel Nature Care Herbs 250ml250ml475205002275960.00%ALMEDA NATURE CARE Dušigeel Nature Care Coconut & Almond 250ml250ml475205002274258.67%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 250ml250ml
11Dušigeel Almeda Nature Care Herbs 500ml500ml475205002268176.00%ALMEDA NATURE CARE Dušigeel Nature Care Herbs 500ml500ml475205002271160.00%ALMEDA NATURE CARE Dušigeel Nature Care Coconut & Almond 500ml500ml475205002270458.67%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 500ml500ml
12Dušigeel Almeda Nature Care meestele 300ml300ml
13Dušigeel Almeda Nature Care Sensitive 300ml300ml
14Dušigeel Almeda Nature Care Sweet Fruits 300ml300ml
15Dušigeel meestele Almeda Nature Care Bergamot 750ml750ml475205002264376.30%ALMEDA NATURE CARE Dušigeel meestele Nature Care Bergamot 750ml750ml475205002267445.97%ALMEDA NATURE CARE Dušigeel Nature Care Fruit Mix 750ml750ml475205002266745.50%ALMEDA NATURE CARE Dušigeel Nature Care Citrus 750ml750ml
16Vahuseep Grapefruit 300ml300ml
17Vahuseep Jasmine 300ml300ml
18Vahuseep Sensitive 300ml300ml
19Vedelseep Almond 300ml300ml
20Vedelseep Almond täide 900ml900ml
21Vedelseep Citrus & Olive 300ml300ml
22Vedelseep Citrus & Olive täide 3l3L
23Vedelseep Citrus & Olive täide 900ml900ml
24Vedelseep Pineapple & Mango 300ml300ml
25Vedelseep Pineapple & Mango täide 900ml900ml
26Vedelseep Sensitive 300ml300ml
27Vedelseep Sensitive täide 900ml900ml
Reseller_2_Sonny7

Note that the database does not have entries for the quantity "300ml" and hence no match is returned.

Here's the modified 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

mudtParameters = GetParameters()

Application.DisplayAlerts = False

'*********************************
'**Get database data into array **
'*********************************
Application.StatusBar = "Reading and storing Database entries"

Set wsDB = ThisWorkbook.Sheets("Database")
With wsDB.UsedRange
    vaDatabase = wsDB.Range("A1").Resize(.Rows.Count, .Columns.Count).Value
End With

Application.StatusBar = "Initialising ..."

'*************************************************************************************
'** 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))
    sCurBrand = StandardiseDBKey(CStr(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

        If 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 Function StandardiseDBKey(ByVal DBKey As String) As String
StandardiseDBKey = WorksheetFunction.Trim(LCase$(DBKey))
End Function

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 = StandardiseDBKey(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
 
Upvote 0

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Hello Alan,

Thank you for another update! :)
There is something I didn't understand, you said "the database does not have entries for the quantity "300ml" and hence no match is returned."

In the Parameters.xls on the Database tab I do have many products with 300ml, like over a thousand.
What did you mean by that?

Also, I tried your new code but I have an error:

Database sequence error
Brand key aibi at row 735 already exists => (see screenshot)

And indeed the brand "AIBI" exist in my database, it's actually changing to another brandname on row 735.

Any idea what this could be?
Thanks!

Greg


Screenshot 2024-04-16 at 16.15.49.jpg
 
Upvote 0
Hi Greg,
The Database isn't sorted - there are a couple of entries "AIBI ECONOM" in the middle of the AIBI entries.

Can you try sorting on Brand (and then optionally Barcode within Brand)
 
Upvote 0
Hi Greg,
Looking at your data, you have brand names such as "7 UP" and "7UP", "7 HEAVEN" and "7HEAVEN" etc. I assume that these pairs should actually be the same brand for our purposes, so have amended the code to allow for this. I recommend that you still sort the data, but this should cater for non-sequential brands:
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 vaBrandBoundsTemp As Variant

Dim WBcur As Workbook
Dim wbResults As Workbook

Dim wsDB As Worksheet
Dim wsCur As Worksheet

mudtParameters = GetParameters()

Application.DisplayAlerts = False

'*********************************
'**Get database data into array **
'*********************************
Application.StatusBar = "Reading and storing Database entries"

Set wsDB = ThisWorkbook.Sheets("Database")
With wsDB.UsedRange
    vaDatabase = wsDB.Range("A1").Resize(.Rows.Count, .Columns.Count).Value
End With

Application.StatusBar = "Initialising ..."

'*************************************************************************************
'** 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))
'    sCurBrand = StandardiseDBKey(CStr(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

        If 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
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
                    ReDim vaBrandBoundsTemp(1 To 3)
                    vaBrandBoundsTemp = mcolBrandbounds(sPrevBrand)
                    vaBrandBounds(2) = vaBrandBoundsTemp(2) & "&" & vaBrandBounds(2)
                    vaBrandBounds(3) = vaBrandBoundsTemp(3) & "&" & vaBrandBounds(3)
                    mcolBrandbounds.Remove (sPrevBrand)
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
'                    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 Function StandardiseDBKey(ByVal DBKey As String) As String

StandardiseDBKey = NormaliseName(DBKey)
End Function

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 lDBBoundsPtr 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 saDBLBounds() As String
Dim saDBUBounds() 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 = StandardiseDBKey(vaCurData(lRow, lMustMatchCol))
        sCurResellerBrand = NormaliseName(CStr(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)
            
            saDBLBounds = Split(vaCurBrandItem(2), "&")
            saDBUBounds = Split(vaCurBrandItem(3), "&")
'Debug.Assert UBound(saDBLBounds) = 0
            For lDBBoundsPtr = LBound(saDBLBounds) To UBound(saDBLBounds)
'                For lDBRow = vaCurBrandItem(2) To vaCurBrandItem(3)
                For lDBRow = Val(saDBLBounds(lDBBoundsPtr)) To Val(saDBUBounds(lDBBoundsPtr))
                    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
            Next lDBBoundsPtr
            
            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
 
Upvote 0
Hi Alan,

I'm very sorry about the sorting totally forgot to make sure of that, and of course it worked.
You are right this list is very messed up, lots strange spellings and characters unfortunately 😖

I've just tried your last code and it works much better indeed.

However if I may add, some results are not showing sometimes although I think it could.
Here is another example: AHMAD TEA

Screenshot 2024-04-17 at 02.15.41.png


On this screenshot you can see that some are repeated like "Roheline" 3 times.
But actually the one with Gunpowder in the word exists in the DB as well as the one "Roheline Jasmiini".

Also it didn't find "piparmündi ja sidruni", it proposed Kummeli instead although the word is exactly like so in the DB. (see below)
I suppose on this one it privileged another one, because the quantity is different, over the word matching.

But I understand that might be asking way too much from your code I suppose 😊

See Database as a reference:

Screenshot 2024-04-17 at 02.25.44.png
 
Upvote 0
Hi Greg
You may want to play with the "Match Algorithm" parameter (set to either "2" or "4").

Failing that we could match on words not the text as a whole. So for the example "AHMAD Tea Tee piparmundi ja sidruni" the code would compare the 6 words with a maximum 600% score, not sure if that would work out well, we'd have to try it and see.

Let's try playing with the "Match Algorithm" first and see how that pans out.

Best wishes

Alan
 
Upvote 0
Of course, Database entries with a quantity different to the Reseller quantity will be excluded from the match.
 
Upvote 0
Hi Greg,
A slightly different approach whereby the code matches on whole words instead of a fuzzy match, which, as a side effect, should reduce the processing time dramatically.
So if the reseller title is "Rulldeodorant Garnier mineral action 50ml" and the Database has the entry "GARNIER Rulldeodorant Mineral Action Control 50ml", the number of words matching is 5 so 100% match (ignoring case). The Brand and quantity filters still apply of course.
This is the new parameter sheet:
GetBarcodes V4.xlsm
ABC
1KeywordValueComment
2Group HeadingBrandHeading in Database and Reseller files of column which MUST match exactly for an entry to be a candidate for comparison
3Match HeadingTitleHeading in Database and Reseller files of column to be fuzzy matched
4DB QuantityQuantityHeading in Database of column containing quantity
5DB BarcodeBarcodeHeading in Database of column containing Barcode
6# Matches per Entry5Return the best 5 matching barcodes
7Min % Match5%Ignore any matches in 'Title' column below 5%
8Match Algorithm4Set to '2' to match pairs then triplets then quads etc, or '4' for Levenstein match. Algorithm 4 is more accurate but slower.
9Show DB TitleYesData item in Database to be shown in results Value must start with 'Y' to be included
10Show DB QuantityYesData item in Database to be shown in results Value must start with 'Y' to be included
11Compare QuantityYesPerform comparison of quantity obtained in Reseller field with Database quantity.
12Word CompareYesMatch on words
Parameters
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A:CExpression=$A1<>""textNO

This is the results sheet:
Book5
ABCDEFGHIJKLMNOPQRSTUVWX
1BrandTitleQuantityBarcodeBarcode #1#1 % Match#1 DB title#1 DB QuantityBarcode #2#2 % Match#2 DB title#2 DB QuantityBarcode #3#3 % Match#3 DB title#3 DB QuantityBarcode #4#4 % Match#4 DB title#4 DB QuantityBarcode #5#5 % Match#5 DB title#5 DB Quantity
2GarnierRulldeodorant Garnier mineral action 50ml50ml3600542475266100.00%GARNIER Rulldeodorant Mineral Action Control 50ml50ml2091890380.00%GARNIER Rulldeodorant Mineral Magnesium 50ml50ml343473073733780.00%GARNIER Rulldeodorant Mineral Hyaluronic Care 50ml50ml360052294345780.00%GARNIER Rulldeodorant ice extreme 50ml 50ml50ml360052321660480.00%GARNIER GARNIER BIO LAVANDIN NIGHT CREAM, 50ml 50ml50ml
3Coca-ColaSoft Coca-Cola Zero 2L2l520654200654760.00%COCA-COLA Karastusjook Zero2l520654200656160.00%COCA-COLA Karastusjook Zero2l21600000047040.00%COCA-COLA Karastusjook2l21600000048740.00%COCA-COLA Karastusjook2l500011261481740.00%COCA-COLA Karastusjook Light2l
4FELIXFelix Magushapu kaste Sweet&Sour 500g ananassiga500g474002966005757.14%FELIX Felix Sweet and Sour Sauce with Pineapple500g477013521712842.86%FELIX Felix Chinese Sauce Semi-Sweet500g200019931031528.57%FELIX Felix Tomato Ketchup500g474002910219928.57%FELIX Felix Mango Sauce500g474002960154828.57%FELIX Felix Pasta Sauce500g
5ColgateHambapasta Triple Action, COLGATE, 75 ml75ml402145762918366.67%COLGATE Hambapasta Colgate total vis.action 75ml 75ml75ml505456309961766.67%COLGATE Hambapasta Triple Action 75ml75ml576522883793166.67%COLGATE Hambapasta maxwhite white crystals 75 ml 75ml75ml629110722510466.67%COLGATE HAMBAPASTA TRIPLE ACTION 75ml75ml871478961530166.67%COLGATE Hambapasta total advanced visible proof 75 ml 75ml75ml
Reseller 1

This is the code:
VBA Code:
Option Explicit

Const msSpecialChars As String = "àáâãäåæÅÆÃÀÂÁÄßçÇÐèéêëÉËÈÊ¡ìíîïÌÎÍÏñÑœðøŒØõòóôöÒÔÓÖÕÚÜÙÛùúûüÝŸýÿ"
Const msSpecialCharsEquivalent As String = "aaaaaaaaaaaaaabccdeeeeeeeeiiiiiiiiinnooooooooooooooouuuuuuuuyyyy"

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
    WordCompare 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 vaBrandBoundsTemp As Variant

Dim WBcur As Workbook
Dim wbResults As Workbook

Dim wsDB As Worksheet
Dim wsCur As Worksheet

mudtParameters = GetParameters()

Application.DisplayAlerts = False

'*********************************
'**Get database data into array **
'*********************************
Application.StatusBar = "Reading and storing Database entries"

Set wsDB = ThisWorkbook.Sheets("Database")
With wsDB.UsedRange
    vaDatabase = wsDB.Range("A1").Resize(.Rows.Count, .Columns.Count).Value
End With

Application.StatusBar = "Initialising ..."

'*************************************************************************************
'** 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))
'    sCurBrand = StandardiseDBKey(CStr(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

        If 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
                
                    ReDim vaBrandBoundsTemp(1 To 3)
                    vaBrandBoundsTemp = mcolBrandbounds(sPrevBrand)
                    vaBrandBounds(2) = vaBrandBoundsTemp(2) & "&" & vaBrandBounds(2)
                    vaBrandBounds(3) = vaBrandBoundsTemp(3) & "&" & vaBrandBounds(3)
                    mcolBrandbounds.Remove (sPrevBrand)

                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 Function StandardiseDBKey(ByVal DBKey As String) As String

StandardiseDBKey = NormaliseName(DBKey)
End Function

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"
        Case "wordcompare"
            GetParameters.WordCompare = 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 **
'** Also convert special chars to a-z                                               **
'*************************************************************************************
'Const msSpecialChars As String = "àáâãäåæÅÆÃÀÂÁÄßçÇÐèéêëÉËÈÊ¡ìíîïÌÎÍÏñÑœðøŒØõòóôöÒÔÓÖÕÚÜÙÛùúûüÝŸýÿ"
'Const msSpecialCharsEquivalent As String = "aaaaaaaaaaaaaabccdeeeeeeeeiiiiiiiiinnooooooooooooooouuuuuuuuyyyy"
Dim lPtr As Long
Dim lSCPtr As Long

Dim sChar As String
Dim sResult As String

For lPtr = 1 To Len(NameX)
    sChar = LCase$(Mid$(NameX, lPtr, 1))
    lSCPtr = InStr(1, msSpecialChars, sChar)
    If lSCPtr > 0 Then sChar = Mid$(msSpecialCharsEquivalent, lSCPtr, 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 lDBBoundsPtr 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 saDBLBounds() As String
Dim saDBUBounds() 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 = StandardiseDBKey(vaCurData(lRow, lMustMatchCol))
        sCurResellerBrand = NormaliseName(CStr(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)
            
            saDBLBounds = Split(vaCurBrandItem(2), "&")
            saDBUBounds = Split(vaCurBrandItem(3), "&")

            For lDBBoundsPtr = LBound(saDBLBounds) To UBound(saDBLBounds)
                For lDBRow = CLng(Val(saDBLBounds(lDBBoundsPtr))) To CLng(Val(saDBUBounds(lDBBoundsPtr)))
                    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
                        If GetParameters.WordCompare = True Then
                            sngCurMatchPercent = WordCompare(String1:=sCurResellerTitle, String2:=mudtDatabase(lDBRow).Title)
                        Else
                            sngCurMatchPercent = FuzzyPercent(String1:=sCurResellerTitle, _
                                                              String2:=mudtDatabase(lDBRow).Title, _
                                                              Algorithm:=mudtParameters.Algorithm, _
                                                              Normalised:=False)
                        End If
                    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
            Next lDBBoundsPtr
            
            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 WordCompare(ByVal String1 As String, ByVal String2 As String) As Single
'****************************************************************************
'** Split strings into words and compare each word, returning a %age match **
'****************************************************************************
Dim lPtr1 As Long
Dim lPtr2 As Long

Dim saString1() As String
Dim saString2() As String

Dim sngScore As Single

saString1 = Split(StandardiseString(String1), " ")
saString2 = Split(StandardiseString(String2), " ")

sngScore = 0
For lPtr1 = 0 To UBound(saString1)
    For lPtr2 = 0 To UBound(saString2)
        If saString1(lPtr1) = saString2(lPtr2) Then
            sngScore = sngScore + 1
            saString2(lPtr2) = "****"
            Exit For
        End If
    Next lPtr2
Next lPtr1
WordCompare = sngScore / (UBound(saString1) + 1)
End Function

Private Function StandardiseString(ByVal Stringx As String) As Variant
'*************************************************************************
'**  Remove non alphanumerics and leading, trailing and multiple spaces **
'*************************************************************************
Dim lPtr As Long

Dim sString As String
Dim sChar As String

sString = LCase$(Trim$(Stringx))

If sString <> "" Then

    '** Replace all nonalphanumerics with a space **
    For lPtr = 1 To Len(Stringx)
         sChar = Mid$(sString, lPtr, 1)
         If InStr("abcdefghijklmnopqrstuvwxyz0123456789", sChar) = 0 Then Mid$(sString, lPtr, 1) = " "
    Next lPtr
End If
'** remove leading, trailing and multiple internal spaces then split into the array **
StandardiseString = WorksheetFunction.Trim(sString)
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
 
Last edited:
Upvote 0
First of all, it's really sophisticated code...
The thing I want help with is this: in the explanations.
"Algorithm
Defines the algorithm to be used to match strings. Valid values are 1, 2 or 3:
Algorithm = 1
This algorithm is best suited for matching misspellings.
For each character in 'String1', a search is performed on 'String2'.
'The search is considered successful if a character is found within 3 characters of the current position in String2
.'
It is said.

I wonder how we can increase the successful search result from 3 characters to 5 or more. thanks
 
Upvote 0
Hi, this code is amazing!!! I am using the code from post #307, but I seem to be having issues if my TableArray is a reference to a different workbook. The function will result in a #VALUE! error. It works perfectly if I just use it all in the same workbook. Just wanted to know if this is just a limitation.

Thanks!

Jordan
 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,108
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

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

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

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

Disable uBlock

Follow these easy steps to disable uBlock

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