Home » excel » Using VBA to identify a product code within an Excel string

Using VBA to identify a product code within an Excel string

Posted by: admin April 23, 2020 Leave a comment

Questions:

Quick background:
I am in the process of creating a search tool in Visual Basic that will allow me to search for inconsistently named materials in my database, that were entered as free text. While I have developed (with the help of Stack Overflow users) a tool which can search for hundreds or items at once, I need to further improve this.

My Question:
I need to be able to pull out item codes from these material descriptions. These items are general numbers such as: 20405-002 or alternatively: A445 or even B463-563. These are the main types of code I would be searching for, and these would be unique identifiers.

Some examples:

In a plant in Italy, I have a material named:

Siemens;Motor;A4002

In a plant in Germany, it is called:

Motor;FP4742;Siemens;TurnFast;A4002

I would search for the terms Siemens, Motor

My current search would return Siemens, Motor next to the first one, and Motor, Siemens next to the second. I would then want the visual basic to in essense say ‘these could be the same part’, then to look within both for a matching code. When it finds the matching code, I would want it to return some sort of indicator in an excel cell.

The overall aim: To have a tool I can use to find if two materials are actually the same, with minimum human input. There could be up to 50,000 materials from each of two plants. I also have the price and supplier of these parts. While the supplier is the same 75% of the time, the price is usually within 20% difference of the same material in a different country. If you have any other ideas as to how to see if two free text materials are actually the same, I’d be happy to hear.

My search code:

Function MultiSplitX(ByVal SourceText As String, RemoveBlankItems As Boolean, ParamArray Delimiters()) As String()
Dim a As Integer, b As Integer, n As Integer
Dim i As Integer: i = 33
Dim u As Variant, v As Variant
Dim tempArr() As String, finalArr() As String, fDelimiters() As String

If InStr(TypeName(Delimiters(0)), "()") <> 0 And LBound(Delimiters) = UBound(Delimiters) Then
    ReDim fDelimiters(LBound(Delimiters(0)) To UBound(Delimiters(0))) 'If passing array vs array items then
    For a = LBound(Delimiters(0)) To UBound(Delimiters(0))            'build that array
        fDelimiters(a) = Delimiters(0)(a)
    Next a
Else
    fDelimiters = Delimiters(0)
End If

Do While InStr(SourceText, Chr(i)) <> 0 'Find an unused character
    i = i + 1
Loop

For a = LBound(fDelimiters) To UBound(fDelimiters) 'Sort Delimiters by length
    For b = a + 1 To UBound(fDelimiters)
        If Len(fDelimiters(a)) < Len(fDelimiters(b)) Then
            u = fDelimiters(b)
            fDelimiters(b) = fDelimiters(a)
            fDelimiters(a) = u
        End If
    Next b
Next a

For Each v In fDelimiters 'Replace Delimiters with a common character
    SourceText = Replace(SourceText, v, Chr(i))
Next

tempArr() = Split(SourceText, Chr(i)) 'Remove empty array items
If RemoveBlankItems = True Then
    ReDim finalArr(LBound(tempArr) To UBound(tempArr))
    n = LBound(tempArr)
    For i = LBound(tempArr) To UBound(tempArr)
        If tempArr(i) <> "" Then
            finalArr(n) = tempArr(i)
            n = n + 1
        End If
    Next i
    n = n - 1
    ReDim Preserve finalArr(LBound(tempArr) To n)

    MultiSplitX = finalArr
Else: MultiSplitX = tempArr
End If
Erase finalArr
Erase tempArr
End Function

Thanks for your help everyone 🙂

How to&Answers:

This is response written in VBA for Excel but used arrays to get/put the data, so you should be able to modify it for a database easily. VB is very similar. If I were to do this work, I would do it in MS Access, in which case you can adapt this code even more easily. Of course, straight VB is always an option. VB is not a great tool for this.

If you work with data much, I strongly recommend you learn the free and open source Python language. You can find a great Python video series for the noob on Youtube from Sentdex. His videos are nice and slow. You will quickly exceed what you can accomplish with VB.

It is difficult to answer the question comprehensively due to the lack of detail and small set of sample data.

There are many ways to approach this, depending on your desired output. I am making the following assumptions.

  1. You are new to coding and want output that is easy to read. As
    such, my solution defaults to a single 2×2 array of results. You
    can change this to 3+ dimensions by setting DeepArr = True.
  2. You want the results pasted in the same worksheet.
  3. You have a separate list of supplier/vendor codes that can be found in the part codes. The GuessSupplier function depends on this assumption. If need be, update the function based on actual requirements.
  4. I call your raw inputs (like Siemens;Motor;A4002) part codes.
  5. I assume the text after the last semi-colon will always be the part
    number. If not, you can easily replace that assumption in the
    GuessPartNum function.

The following describes the spreadsheet I used for simple testing.
Sheet “PartCodes” contains the part codes in a single column with sample values in cells B3:B6 (header in B2). Columns G-H are reserved for the results.
Sheet “Suppliers” contains the unique supplier list in a single column (B3:B6).
You can specify sheet names and ranges for inputs and output in the RunMain() sub.
For convenience, I hard coded the sheet names in some places. You should bring these to the surface as arguments.
The code is somewhat verbose to make it easy to understand.
I did not test performance, as I do not have the data set and expect you will run this infrequently.
I added only a trivial amount of error handling.

My complete set of code is below. You will find the RunMain() sub near the bottom. This kicks off the Main() sub that controls the workflow.

Option Base 0 Option Explicit ' 1) Manually eliminate duplicates in your parts list using Excel built-in feature. ' a) highlight the range ' b) Data ribbon > Remove Duplicates ' 2) Create a supplier list on a separate sheet in teh same workbook ' 3) Edit the RunMain() procedure per your data. I assume: your part code list ' - part code list is in cells B3:B10 of the PartCodes sheet. ' - supplier list in cells b4:b6 of Suppliers sheet. ' - output goes to D2 in PartCodes sheet. ' 4) Run the RunMain() procedure simply kicks off Main. ' Main() sub does the following: ' a)Run ProcessPartCodes: ' i. load the parts codes from the worksheet into an array ' ii. run GuessPartNum and GuessSupplier and place results in the parts code array. ' b) Run FindMatches to add more to the array. Finds other part codes that may be for the same part. ' Logic is described in the function. ' c) Run ArrayToRange to paste part of the result set to the workseet. Note that ' the ourput array is more than 2 dimensions, so not all data is pasted neatly. ' I leave it to you to determine how you want to format the data for output. ' Function RangeToArray(inputRange As Range) 'Copies values from a rectangular range to a 2D Array. 'Array is always 2D, even if data is a single column or row. 'inputRange: a rectangular range Dim Col1 As Integer, row1 As Integer Dim i As Integer, j As Integer Dim rowCnt As Integer Dim colCnt As Integer Dim retArr() As Variant ' Size output array rowCnt = inputRange.Rows.Count colCnt = inputRange.Columns.Count ReDim retArr(1 To rowCnt, 1 To colCnt) As Variant ' Load range values into array For i = 1 To rowCnt For j = 1 To (colCnt) retArr(i, j) = Trim(inputRange.Cells(i, j)) Next j Next i ' Return array RangeToArray = retArr End Function Sub ArrayToRange(myArr As Variant, Target As Range) ' Copies the content of a 2D array to a Range. ' myArr must be exactly 2 dimensions ' Target is a range. If more than 1 cell, the top left cell is used. ' Copies the array to the range starting with the top left cell. ' Target Range size can be a single cell and need not match the array dimensions. Dim r As Long, tgtRow As Long Dim c As Long, tgtCol As Long Dim firstRow As Long Dim firstCol As Long Dim lastRow As Long Dim lastCol As Long ' Find the top left cell of the Target Range tgtRow = Target.Row tgtCol = Target.Column ' Set target range dimesions based on array size. firstRow = tgtRow + LBound(myArr, 1) firstCol = tgtCol + LBound(myArr, 2) lastRow = tgtRow + UBound(myArr, 1) lastCol = tgtCol + UBound(myArr, 2) ' The next row would usually work. If you get funky data, it will fail, ' so, we will use a loop instead. ' Range(Cells(firstRow, firstCol), Cells(lastRow, lastCol)) = myArr ' Loop through rows and columns, setting cell values one at a time. For r = LBound(myArr, 1) To UBound(myArr, 1) For c = LBound(myArr, 2) To UBound(myArr, 2) On Error Resume Next ' Prevent one bad value from killing the entire operation. Cells(tgtRow + r - 1, tgtCol + c) = myArr(r, c) On Error GoTo 0 Next c Next r End Sub ' Not used, this is just an example 'Public Function RangeCorners(Optional MyRange As Range = Range("c2:c10")) ' TopLeft = MyRange.Cells(1) ' BottomLeft = MyRange.Cells(.Rows.Count, 1) ' TopRight = MyRange.Cells(1, .Columns.Count) ' BottomRigt = MyRange.Cells(.Cells.Count) ' RangeCorners = Array(TopLeft, TopRight, BottomLeft, BottomRight) 'End Function Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean 'Returns True if stringToBeFound is in the array (arr); else False 'This one-liner need not be in a fucntion, but makes reading code easier. IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1) End Function Function GuessPartNum(splitPartCode As Variant, Optional delim As String = ";") ' Find a way to determine what part of the partCode is the part number. ' Perhaps it is always last. Perhaps it always has at least 3 digits. ' Simply takes the last item from the part code. Update this logic to whatever ' makes sense for your dataset (which I could nto see when writing this). GuessPartNum = splitPartCode(UBound(splitPartCode)) End Function Function GuessSupplier(splitPartCode As Variant, supplierList As Variant, Optional delim As String = ";") ' Determine the supplier of this part from the partCode. ' For each supplier in the supplierList, see if the supplier name is in the partCode. Dim i As Integer For i = LBound(supplierList) To UBound(supplierList) 'Simply verifies if a supplier from supplierList is in the part code. Uses first match. If (UBound(Filter(splitPartCode, supplierList(i, 1))) > -1) Then 'if arr(i) is in supplier_array GuessSupplier = supplierList(i, 1) Exit Function End If Next i End Function Function ProcessPartCodes(partCodeRange As Range, supplierListRange As Range, Optional delim As String = ";") ' Main ProcessPartCodes ' ' PartCodeRange: a range representing the part code list; ' must be in single column form. ' SupplierList: array of supplier names as strings ' ' Load part code array into array Dim resultArr As Variant 'result set as array Dim supplierList As Variant Dim splitCode As Variant Dim i As Integer resultArr = RangeToArray(partCodeRange) ReDim Preserve resultArr(LBound(resultArr) To UBound(resultArr), 0 To 4) As Variant supplierList = RangeToArray(supplierListRange) ' Get supplier and part num from each part code For i = LBound(resultArr) To UBound(resultArr) If Len(resultArr(i, 0)) > 0 Then splitCode = Split(resultArr(i, 0), delim) ' Split the partCode by delimiters, semi-colon (;) resultArr(i, 0) = resultArr(i, 0) ' Part Code (not parsed) resultArr(i, 1) = GuessPartNum(splitCode) ' Part Number resultArr(i, 2) = GuessSupplier(splitCode, supplierList) ' Supplier resultArr(i, 3) = splitCode ' Part Code (parsed) 'resultArr(i, 4) ' reserved for match information Else ' Empty array element. splitCode = "" resultArr(i, 3) = Array() End If Next i ProcessPartCodes = resultArr End Function Function CompareParts(splitPartCode1 As Variant, splitPartCode2 As Variant) ' ' 'splitPartCode1 is an array of a parsed partCode string 'splitPartCode2 is an array of a parsed partCode string Dim matches() As String Dim i As Integer Dim matchCnt As String ReDim matches(0 To 0) As String ' Check each item in arr1 (each substring of partCode1) for a match in arr2 For i = LBound(splitPartCode1) To UBound(splitPartCode1) If (UBound(Filter(splitPartCode2, splitPartCode1(i))) > -1) Then 'if arr1(i) is in arr2 ' Found an item in splitPartCode1 (a substring in partCode1) that is also in splitPartCode2. ' Add this item to the list of matches. If LBound(matches) = -1 Then ReDim matches(0 To 0) As String Else ReDim Preserve matches(LBound(matches) To UBound(matches) + 1) As String ' grow the matches array by one End If matches(UBound(matches)) = splitPartCode1(i) ' set value of last item in matches() = this item (this substring of partCode1) End If Next i matchCnt = UBound(matches) - LBound(matches) + 1 ' Total number of matching substrings from each part. CompareParts = Array(matchCnt, matches) End Function Function FindMatches(partCodeArr As Variant, Optional DeepArr As Boolean = False) ' Fucntion compares 2 part numbers to determine likelihood of a match. ' Parses partCode1 and partCode2 using the delimiter into arrays of strings. ' Then counts the number of matching strings in each array. ' Then determines if the part numbers (assumed to be the last string of each array) match. ' After running this, you can use the match count (matchCnt integer) and part number match ' (partNumMatch boolean) as a basis for determining how likely it is that partCode1=partCode2. ' ' ' DeepArr: If True, returns 3+ dimensional array. If False, flattens results to 2D array. ' ' Returns: Array(partCode1, partCode2, partNum1, partNum2, matchCnt, pricePct, supplierMatch, partNumMatch) ' partCode1 = partCode1 input argument ' partCode2 = partCode2 input argument ' partNum1 = the portion (substring) of partCode1 after the last ocurrence of the delimiter, delim. ' partNum2 = the portion (substring) of partCode2 after the last ocurrence of the delimiter, delim. ' match (boolean) = True if parts are likely the same. ' matchCnt = number of matching sub-strings between partCode1 and part 2 ' (essentially, a match score, where higher is more likely a positive match) ' Returns -1 if partCode1=partCode2, meaning exact match. ' pricePct = percentage price match calculated as (decimal portion of price1/price2) * 100 ' partNumMatch = True is partNum1=partNum2; else False Dim i As Integer, j As Integer, k As Integer Dim partCodei, partCodej Dim partNumi As String, partNumj As String, numMatch As Boolean Dim Duplicate As Boolean, newMatch As Boolean Dim partSupplieri As String, partSupplierj As String, supplierMatch As Boolean Dim splitCodei() As String, splitCodej() As String, matchCnt As Integer Dim splitCompare Dim matches() As String 'empty array has LBound=0 and UBound=-1, so UBound-LBound=-1 indicates an empty array Dim matchstr As String Dim s As String matchCnt = 0 ' matchCnt = UBound(matches) - LBound(matches) + 1 ' starting with 0 matches. For i = LBound(partCodeArr) To UBound(partCodeArr) If i = 1 Or i = UBound(partCodeArr) Or i Mod 100 = 0 _ Then Debug.Print "Starting record " & i & ": " & Now() If partCodeArr(i, 0) <> "" Then matchstr = "" For j = i + 1 To UBound(partCodeArr) If Len(partCodeArr(j, 0)) > 0 Then partCodei = partCodeArr(i, 0) partCodej = partCodeArr(j, 0) Duplicate = partCodei = partCodej 'found duplicate entry in table. partNumi = partCodeArr(i, 1) partNumj = partCodeArr(j, 1) numMatch = partNumi = partNumj partSupplieri = partCodeArr(i, 2) partSupplierj = partCodeArr(j, 2) supplierMatch = partSupplieri = partSupplierj splitCodei = partCodeArr(i, 3) splitCodej = partCodeArr(j, 3) splitCompare = CompareParts(splitCodei, splitCodej) matchCnt = splitCompare(0) newMatch = False If Duplicate Then ' You should have removed duplicates before starting. On Error GoTo redimErr ReDim Preserve matches(0 To UBound(matches) + 1, 0 To 2) As String On Error GoTo 0 newMatch = True matches(UBound(matches), 0) = partCodej 'The duplicate partCode matches(UBound(matches), 1) = "0" ' Matching score, where -1 indicates an exact duplicate. matches(UBound(matches), 2) = "Duplicate Entry. Part codes are identical." ' Matching score, where -1 indicates an exact duplicate. ElseIf supplierMatch And numMatch Then ' Possible duplicate part since supplier and part number both match. On Error GoTo redimErr ReDim Preserve matches(0 To UBound(matches) + 1, 0 To 2) As String On Error GoTo 0 newMatch = True matches(UBound(matches), 0) = partCodej 'The duplicate partCode matches(UBound(matches), 1) = "1" ' Matching score, where -1 indicates an exact duplicate. matches(UBound(matches), 2) = "Probably same part with differnt part code. Same supplier and part number." ' Matching score, where -1 indicates an exact duplicate. ElseIf supplierMatch And matchCnt > 2 Then ' Possible duplicate part since supplier and part number both match. On Error GoTo redimErr ReDim Preserve matches(0 To UBound(matches) + 1, 0 To 2) As String On Error GoTo 0 newMatch = True matches(UBound(matches), 0) = partCodej 'The duplicate partCode matches(UBound(matches), 1) = "2" ' Matching score, where -1 indicates an exact duplicate. matches(UBound(matches), 2) = "Possible duplicate. More likely a similar part from same supplier" ' Matching score, where -1 indicates an exact duplicate. ElseIf supplierMatch = False And matchCnt > 2 Then ' Possible duplicate part since supplier and part number both match. On Error GoTo redimErr ReDim Preserve matches(0 To UBound(matches) + 1, 0 To 2) As String On Error GoTo 0 newMatch = True matches(UBound(matches), 0) = partCodej 'The duplicate partCode matches(UBound(matches), 1) = "3" ' Matching score, where -1 indicates an exact duplicate. matches(UBound(matches), 2) = "Possible part match from different supplier" ' Matching score, where -1 indicates an exact duplicate. ElseIf supplierMatch = False And matchCnt > 1 Then ' Possible duplicate part since supplier and part number both match. On Error GoTo redimErr ReDim Preserve matches(0 To UBound(matches) + 1, 0 To 2) As String On Error GoTo 0 newMatch = True matches(UBound(matches), 0) = partCodej 'The duplicate partCode matches(UBound(matches), 1) = "4" ' Matching score, where -1 indicates an exact duplicate. matches(UBound(matches), 2) = "Low probability part match from different supplier" ' Matching score, where -1 indicates an exact duplicate. End If If newMatch And Not DeepArr Then For k = LBound(matches) To UBound(matches) matchstr = matchstr & "[" & partCodej & "," & matches(UBound(matches), 1) & "," & matches(UBound(matches), 2) & "], " Next k End If End If Next j If DeepArr Then ' return 3+ dimensional array partCodeArr(i, 4) = matches Else ' return 2D array for easier pasting to worksheet ' Flatten partCodeArr(i, 4), the parsed potential part matches to an ordinary string ' with format [[part code, match value, match description],[part code, match value, match description],...] If Len(matchstr) > 0 Then matchstr = "[ " & Left(matchstr, Len(matchstr) - 2) & "] " End If partCodeArr(i, 4) = matchstr ' Flatten the parsed part code back to original string format. partCodeArr(i, 3) = partCodeArr(i, 0) End If ReDim matches(0) As String End If Next i FindMatches = partCodeArr Exit Function redimErr: ReDim matches(0 To 0, 0 To 2) As String Resume Next End Function Sub RunMain() ' Kicks off Main(partCodeRange As Range, supplierListRange As Range, destination As Range) ' ' Arguments: ' partCodeRange = Excel Range (not string name of range) ' that contains the raw part code list ' supplierListRange = Excel Range (not string name of range) ' that contains a unique list of supplier ' codes found in the part codes. ' Call Main(Sheets("PartCodes").Range("B3:B10"), Sheets("Suppliers").Range("B4:B6"), Range("PartCodes!D2")) End Sub Sub Main(partCodeRange As Range, supplierListRange As Range, destination As Range) ' This is the main sub that runs the full process of finding equivalent part ' codes and writing the findings to an excel worksheet. ' See RunMain() sub for example use. ' ' Arguments: ' partCodeRange = Excel Range (not string name of range) ' that contains the raw part code list ' supplierListRange = Excel Range (not string name of range) ' that contains a unique list of supplier ' codes found in the part codes. ' Dim partCodesArr, matchArr Dim startdate As Date, stopdate As Date startdate = Now() Debug.Print Debug.Print String(70, "*") Debug.Print Debug.Print "Starting: " & startdate Debug.Print partCodesArr = ProcessPartCodes(partCodeRange, supplierListRange) matchArr = FindMatches(partCodesArr) ' FindMatches(partCodesArr, True) for 3+ dimensional results Sheets("PartCodes").Activate 'Write column headers. destination.Offset(0, 0) = "Part Code" destination.Offset(0, 1) = "Part Num" destination.Offset(0, 2) = "Part Supplier" destination.Offset(0, 3) = "Part Code" destination.Offset(0, 4) = "Potential equivalent part numbers" Call ArrayToRange(matchArr, destination.Offset(1, 0)) stopdate = Now() Debug.Print Debug.Print "Finished: " & stopdate Debug.Print Debug.Print "Run time: " & (stopdate - startdate) Debug.Print Debug.Print String(70, "*") Debug.Print End Sub