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
