Option Explicit
Type Params
GroupHeading As String
MatchHeading As String
MatchesCount As Long
MinPercent As Single
Algorithm As Single
DBQuantity As String
DBBarcode As String
ShowTitle As Boolean
ShowQty As Boolean
End Type
Dim mudtParameters As Params
Type BrandBounds
BrandName As String
BrandLB As Long
BrandUB As Long
End Type
Dim mcolBrandbounds As Collection
Type DatabaseData
Brand As String
Title As String
Qty As String
BarCode As String
End Type
Dim mudtDatabase() As DatabaseData
Type BarCodeMatches
BarCode As String
BrandPercent As Single
MatchText As String
Qty As String
End Type
Sub click_GetBarcodes()
Dim lUB As Long
Dim lLastUB As Long
Dim lRow As Long
Dim saCurName() As String
Dim sCurTerminalName As String
Dim sPrevBrand As String
Dim sCurBrand As String
Dim vCurFilename As Variant
Dim vResellerFiles As Variant
Dim vaDatabase As Variant
Dim vaBrandLimits As Variant
Dim vaDicBrandItem As Variant
Dim vaBrandBounds As Variant
Dim udtBrandBound As BrandBounds
Dim WBcur As Workbook
Dim wbResults As Workbook
Dim wsDB As Worksheet
Dim wsCur As Worksheet
mudtParameters = GetParameters()
Application.DisplayAlerts = False
'*********************************
'**Get database data into array **
'*********************************
Set wsDB = ThisWorkbook.Sheets("Database")
With wsDB.UsedRange
vaDatabase = wsDB.Range("A1").Resize(.Rows.Count, .Columns.Count).Value
End With
'*************************************************************************************
'** Set up Brands bounds collection **
'** Note that the database entries MUST be sorted into ascending brand sequence! **
'*************************************************************************************
Set mcolBrandbounds = New Collection
lUB = 0
sPrevBrand = ""
ReDim vaBrandBounds(1 To 3)
For lRow = 2 To UBound(vaDatabase, 1)
sCurBrand = NormaliseName(vaDatabase(lRow, 1))
If sCurBrand <> "" Then
If sCurBrand < sPrevBrand Then
MsgBox prompt:="Database file MUST be sorted into ascending Brand sequence", _
Buttons:=vbOKOnly + vbCritical, _
Title:="Database Data Error"
Set mcolBrandbounds = Nothing
Exit Sub
ElseIf sCurBrand = sPrevBrand Then
'** Update End row for current brand
vaBrandBounds(3) = lRow
Else
'** Here if new brand entry row encountered **
If sPrevBrand <> "" Then
On Error Resume Next
mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds
On Error GoTo 0
End If
vaBrandBounds(1) = sCurBrand
vaBrandBounds(2) = lRow
vaBrandBounds(3) = lRow
sPrevBrand = sCurBrand
End If
End If
Next lRow
On Error Resume Next
mcolBrandbounds.Add key:=sPrevBrand, Item:=vaBrandBounds '** Write final entry **
On Error GoTo 0
'**************************************************
'** Store database in the udt array mudtDatabase **
'**************************************************
Call PopulateDatabaseEntries(DBArray:=vaDatabase)
'***********************************
'** Get input reseller file names **
'***********************************
vResellerFiles = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", _
Title:="Please select Reseller Excel file(s)", _
MultiSelect:=True)
If IsArray(vResellerFiles) = False Then Exit Sub
'****************************
'** 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 files **
'****************************
For Each vCurFilename In vResellerFiles
Call ProcessInputFile(DBData:=vaDatabase, _
InputFileName:=vCurFilename, _
ResultsWB:=wbResults)
Next vCurFilename
On Error Resume Next
wbResults.Sheets(1).Delete
On Error GoTo 0
Application.StatusBar = False
End Sub
Private Sub PopulateDatabaseEntries(ByVal DBArray As Variant)
'************************************
'** Create entries in mudtDataBase **
'************************************
Dim lRow As Long
Dim lCol As Long
Dim lColBrand As Long
Dim lColTitle As Long
Dim lColQty As Long
Dim lColBarCode As Long
Dim lEntriesPtr As Long
Dim sCurHeading As String
For lCol = 1 To UBound(DBArray, 2)
sCurHeading = NormaliseName(CStr(DBArray(1, lCol)))
Select Case sCurHeading
Case NormaliseName(mudtParameters.GroupHeading)
lColBrand = lCol
Case NormaliseName(mudtParameters.MatchHeading)
lColTitle = lCol
Case NormaliseName(mudtParameters.DBQuantity)
lColQty = lCol
Case NormaliseName(mudtParameters.DBBarcode)
lColBarCode = lCol
End Select
Next lCol
ReDim mudtDatabase(1 To 1)
lEntriesPtr = 1
mudtDatabase(1).Brand = ""
On Error Resume Next
For lRow = 2 To UBound(DBArray, 1)
If Trim$(DBArray(lRow, lColBrand)) <> "" Then
lEntriesPtr = lEntriesPtr + 1
ReDim Preserve mudtDatabase(1 To lEntriesPtr)
On Error Resume Next
mudtDatabase(lEntriesPtr).BarCode = CStr(DBArray(lRow, lColBarCode))
mudtDatabase(lEntriesPtr).Brand = NormaliseName(DBArray(lRow, lColBrand))
mudtDatabase(lEntriesPtr).Qty = CStr(DBArray(lRow, lColQty))
mudtDatabase(lEntriesPtr).Title = CStr(DBArray(lRow, lColTitle))
On Error GoTo 0
End If
Next lRow
End Sub
Private Function GetParameters() As Params
'***********************************************
'** Return parameters from sheet 'parameters' **
'***********************************************
Dim lRow As Long
Dim lEndRow As Long
Dim sCurKeyword As String
Dim sCurValue As String
Dim vaParamData As Variant
'** Store parameter data into array **
vaParamData = ThisWorkbook.Sheets("Parameters").Range("A1").CurrentRegion.Resize(, 2).Value
For lRow = 2 To UBound(vaParamData, 1)
sCurKeyword = LCase$(Replace(vaParamData(lRow, 1), " ", "")) '** Remove all spaces and convert to lowercase
Select Case sCurKeyword
Case "" '** Ignore empty keyword cells **
Case "groupheading"
GetParameters.GroupHeading = NormaliseName(vaParamData(lRow, 2))
Case "matchheading"
GetParameters.MatchHeading = NormaliseName(vaParamData(lRow, 2))
Case "#matchesperentry"
GetParameters.MatchesCount = Val(vaParamData(lRow, 2))
Case "min%match"
GetParameters.MinPercent = Val(vaParamData(lRow, 2))
Case "matchalgorithm"
GetParameters.Algorithm = Val(vaParamData(lRow, 2))
Case "dbquantity"
GetParameters.DBQuantity = CStr(vaParamData(lRow, 2))
Case "dbbarcode"
GetParameters.DBBarcode = CStr(vaParamData(lRow, 2))
Case "showdbtitle"
GetParameters.ShowTitle = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
Case "showdbquantity"
GetParameters.ShowQty = LCase$(Left$(vaParamData(lRow, 2), 1)) = "y"
End Select
Next lRow
End Function
Private Function NormaliseName(ByVal NameX As String) As String
'*************************************************************************************
'** Remove all but "abcdefghijklmnopqrstuvwxyz0123456789", and convert to lowercase **
'*************************************************************************************
Dim lPtr As Long
Dim sChar As String
Dim sResult As String
For lPtr = 1 To Len(NameX)
sChar = LCase$(Mid$(NameX, lPtr, 1))
If InStr("abcdefghijklmnopqrstuvwxyz0123456789", sChar) > 0 Then sResult = sResult & sChar
Next lPtr
NormaliseName = sResult
End Function
Private Sub ProcessInputFile(ByVal DBData As Variant, _
ByVal InputFileName As Variant, _
ByRef ResultsWB As Workbook)
Dim lCol As Long
Dim lRow As Long
Dim lPtr As Long
Dim lMustMatchCol As Long
Dim lMatchCol As Long
Dim lLB As Long
Dim lUB As Long
Dim lDBRow As Long
Dim lPtr1 As Long
Dim lPtr2 As Long
Dim lSheetCount As Long
Dim lResultsColumnCount As Long
Dim sCurHeading As String
Dim sTerminalName As String
Dim sCurResellerBrand As String
Dim sCurResellerTitle As String
Dim sCurDBTitle As String
Dim sngCurMatchPercent As Single
Dim udtBarCodeMatches() As BarCodeMatches
Dim udtBrandBounds As BrandBounds
Dim vaCurData As Variant
Dim vaMatchResultsData As Variant
Dim vaCurBrandItem As Variant
Dim WB As Workbook
Dim WS As Worksheet
Dim wsResults As Worksheet
lMustMatchCol = 0
lMatchCol = 0
sTerminalName = GetTerminalName(InputFileName)
Application.StatusBar = "Processing " & sTerminalName
Application.ScreenUpdating = False
On Error Resume Next
Set WB = Nothing
Set WB = Workbooks.Open(Filename:=InputFileName, _
UpdateLinks:=True, _
ReadOnly:=True, _
corruptload:=xlRepairFile)
If Err.Number > 0 Then
MsgBox prompt:=Err.Description, Buttons:=vbOKOnly + vbCritical, Title:="Unable to open file " & sTerminalName
End If
On Error GoTo 0
If WB Is Nothing Then Exit Sub
Set WS = WB.Sheets(1)
With WS.UsedRange
vaCurData = WS.Range("A1").Resize(.Rows.Count, .Columns.Count).Value '** Get input Reseller data
End With
'** Initialise results array **
lResultsColumnCount = 2
If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
ReDim vaMatchResultsData(1 To UBound(vaCurData, 1), 1 To mudtParameters.MatchesCount * lResultsColumnCount) '** set size of array for Results
For lCol = 1 To mudtParameters.MatchesCount
lPtr = ((lCol - 1) * lResultsColumnCount) + 1
vaMatchResultsData(1, lPtr) = "Barcode #" & lCol
vaMatchResultsData(1, lPtr + 1) = "#" & lCol & " % Match"
lPtr1 = lPtr + 1
If mudtParameters.ShowTitle = True Then
lPtr1 = lPtr1 + 1
vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB " & mudtParameters.MatchHeading
End If
If mudtParameters.ShowQty = True Then
lPtr1 = lPtr1 + 1
vaMatchResultsData(1, lPtr1) = "#" & lCol & " DB Quantity"
End If
Next lCol
'** Check that we have the 2 required heading columns in row 1**
For lCol = 1 To UBound(vaCurData, 2)
sCurHeading = NormaliseName(CStr(vaCurData(1, lCol)))
If sCurHeading = mudtParameters.GroupHeading Then lMustMatchCol = lCol
If sCurHeading = mudtParameters.MatchHeading Then lMatchCol = lCol
Next lCol
If lMustMatchCol > 0 _
And lMatchCol > 0 Then
'** Process the reseller **
lSheetCount = ResultsWB.Worksheets.Count
Set wsResults = ResultsWB.Sheets.Add(after:=ResultsWB.Sheets(lSheetCount)) '** Add a new worksheet to the results workbook
On Error Resume Next
wsResults.Name = sTerminalName '** set the sheetname to the reseller file terminal name
On Error GoTo 0
'** MAIN LOOP **
For lRow = 2 To UBound(vaCurData, 1)
With Application
.ScreenUpdating = True
.StatusBar = "Processing Reseller file " & sTerminalName & ", row " & lRow & " of " & UBound(vaCurData, 1)
.ScreenUpdating = False
End With
sCurResellerBrand = NormaliseName(vaCurData(lRow, lMustMatchCol))
sCurResellerTitle = vaCurData(lRow, lMatchCol)
If CollectionKeyExists(coll:=mcolBrandbounds, key:=sCurResellerBrand) Then
ReDim vaCurBrandItem(1 To 3)
vaCurBrandItem = mcolBrandbounds.Item(sCurResellerBrand)
'** Initialise array **
ReDim udtBarCodeMatches(1 To mudtParameters.MatchesCount + 1)
For lPtr = 1 To UBound(udtBarCodeMatches)
With udtBarCodeMatches(lPtr)
.BarCode = ""
.BrandPercent = 0
.MatchText = ""
.Qty = ""
End With
Next lPtr
sCurResellerTitle = vaCurData(lRow, lMatchCol)
For lDBRow = vaCurBrandItem(2) To vaCurBrandItem(3)
sngCurMatchPercent = FuzzyPercent(String1:=sCurResellerTitle, _
String2:=mudtDatabase(lDBRow).Title, _
Algorithm:=mudtParameters.Algorithm, _
Normalised:=False)
If sngCurMatchPercent >= mudtParameters.MinPercent Then
For lPtr1 = 1 To mudtParameters.MatchesCount
If sngCurMatchPercent > udtBarCodeMatches(lPtr1).BrandPercent Then
For lPtr2 = mudtParameters.MatchesCount - 1 To lPtr1 Step -1
If udtBarCodeMatches(lPtr2).BrandPercent <> 0 Then
With udtBarCodeMatches(lPtr2 + 1)
.BarCode = udtBarCodeMatches(lPtr2).BarCode
.BrandPercent = udtBarCodeMatches(lPtr2).BrandPercent
.MatchText = udtBarCodeMatches(lPtr2).MatchText
.Qty = udtBarCodeMatches(lPtr2).Qty
End With
End If
Next lPtr2
With udtBarCodeMatches(lPtr1)
.BarCode = mudtDatabase(lDBRow).BarCode
.BrandPercent = sngCurMatchPercent
.MatchText = mudtDatabase(lDBRow).Title
.Qty = mudtDatabase(lDBRow).Qty
End With
Exit For
End If
Next lPtr1
End If
Next lDBRow
For lCol = 1 To mudtParameters.MatchesCount
If udtBarCodeMatches(lCol).BrandPercent > 0 Then
lPtr = ((lCol - 1) * lResultsColumnCount) + 1
vaMatchResultsData(lRow, lPtr) = "'" & udtBarCodeMatches(lCol).BarCode
vaMatchResultsData(lRow, lPtr + 1) = udtBarCodeMatches(lCol).BrandPercent
lPtr1 = lPtr + 1
If mudtParameters.ShowTitle = True Then
lPtr1 = lPtr1 + 1
vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).MatchText
End If
If mudtParameters.ShowQty = True Then
lPtr1 = lPtr1 + 1
vaMatchResultsData(lRow, lPtr1) = udtBarCodeMatches(lCol).Qty
End If
End If
Next lCol
End If
Next lRow
'** Store results into worksheet **
wsResults.Range("A1").Resize(UBound(vaCurData, 1), UBound(vaCurData, 2)).Value = vaCurData
lResultsColumnCount = 2
If mudtParameters.ShowTitle = True Then lResultsColumnCount = lResultsColumnCount + 1
If mudtParameters.ShowQty = True Then lResultsColumnCount = lResultsColumnCount + 1
With wsResults.Range("A1").Offset(, UBound(vaCurData, 2))
For lCol = 1 To mudtParameters.MatchesCount
lPtr = ((lCol - 1) * lResultsColumnCount)
With .Offset(, lPtr + 1).Resize(wsResults.Rows.Count, 1)
.NumberFormat = "0.00%"
.HorizontalAlignment = xlLeft
End With
Next lCol
.Resize(UBound(vaMatchResultsData, 1), UBound(vaMatchResultsData, 2)).Value = vaMatchResultsData
End With
wsResults.UsedRange.Resize(1).Font.Bold = True
wsResults.Cells.EntireColumn.AutoFit
End If
WB.Close savechanges:=False
Application.ScreenUpdating = True
End Sub
Function CollectionKeyExists(coll As Collection, key As String) As Boolean
On Error GoTo EH
IsObject (coll.Item(key))
CollectionKeyExists = True
EH:
End Function
Private Function GetTerminalName(ByVal Filenamex As Variant) As String
'*****************************************************************
'** Return final element of filename (excluding file extension) **
'*****************************************************************
Dim lUB As Long
Dim saSplit() As String
Dim saSplit2() As String
saSplit = Split(Filenamex, Delimiter:=Application.PathSeparator)
lUB = UBound(saSplit)
saSplit2 = Split(saSplit(lUB), ".")
GetTerminalName = saSplit2(0)
End Function
