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
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 mcolBrandbounds = New Collection
lUB = 0
sPrevBrand = ""
ReDim vaBrandBounds(1 To 3)
For lRow = 2 To UBound(vaDatabase, 1)
sCurBrand = NormaliseName(vaDatabase(lRow, 1))
If sCurBrand <> "" Then
If sCurBrand = sPrevBrand Then
vaBrandBounds(3) = lRow
Else
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
On Error GoTo 0
Call PopulateDatabaseEntries(DBArray:=vaDatabase)
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
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
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)
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
Dim lRow As Long
Dim lEndRow As Long
Dim sCurKeyword As String
Dim sCurValue As String
Dim vaParamData As Variant
vaParamData = ThisWorkbook.Sheets("Parameters").Range("A1").CurrentRegion.Resize(, 2).Value
For lRow = 2 To UBound(vaParamData, 1)
sCurKeyword = LCase$(Replace(vaParamData(lRow, 1), " ", ""))
Select Case sCurKeyword
Case ""
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
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
End With
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)
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
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
lSheetCount = ResultsWB.Worksheets.Count
Set wsResults = ResultsWB.Sheets.Add(after:=ResultsWB.Sheets(lSheetCount))
On Error Resume Next
wsResults.Name = sTerminalName
On Error GoTo 0
For lRow = 2 To UBound(vaCurData, 1)
With Application
.ScreenUpdating = True
.StatusBar = "Processing Reseller file " & sTerminalName & ", row " & lRow & " of " & UBound(vaCurData, 1)
.ScreenUpdating = False
End With
sCurResellerBrand = NormaliseName(CStr(vaCurData(lRow, lMustMatchCol)))
sCurResellerTitle = vaCurData(lRow, lMatchCol)
If CollectionKeyExists(coll:=mcolBrandbounds, key:=sCurResellerBrand) Then
ReDim vaCurBrandItem(1 To 3)
vaCurBrandItem = mcolBrandbounds.Item(sCurResellerBrand)
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
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
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
Dim lPtr As Long
Dim sString As String
Dim sChar As String
sString = LCase$(Trim$(Stringx))
If sString <> "" Then
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
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
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
