Это ответ написан в VBA для Excel, но используемые массивы, чтобы получить/поместить данные, так что вы должны быть способный легко модифицировать его для базы данных. VB очень аналогичный. Если бы я должен был выполнить эту работу, я бы сделал это в MS Access, и в этом случае вы можете легче адаптировать этот код. Конечно, прямой VB всегда вариант. VB - отличный инструмент для этого.
Если вы много работаете с данными, я настоятельно рекомендую вам изучить свободный и открытый исходный язык Python.Вы можете найти отличную серию видео Python для noob на Youtube от Sentdex. Его видео приятно и медленно. Вы быстро превысите то, что можете выполнить с помощью VB.
Трудно ответить на вопрос всесторонне из-за отсутствия деталей и небольшого набора данных выборки.
Есть много способов приблизиться к этому, в зависимости от желаемого результата. Я делаю следующие предположения.
- Вы новичок в кодировании и хотите получить результат, который легко читать. Так как такое, мое решение по умолчанию имеет один массив результатов 2x2. Вы можете изменить это значение до 3 + измерений, установив DeepArr = True.
- Вы хотите, чтобы результаты были вставлены на том же рабочем листе.
- У вас есть отдельный список кодов поставщиков/поставщиков, которые можно найти в кодах деталей. Функция GuessSupplier зависит от этого предположения. Если необходимо, обновите функцию на основе фактических требований.
- Я называю ваши необработанные входы (например, Siemens; Motor; A4002).
- Я предполагаю, что текст после последней запятой всегда будет частью номер. Если нет, вы можете легко заменить это предположение в функции GuessPartNum.
Следующая таблица описывает таблицу, которую я использовал для простого тестирования. Лист «PartCodes» содержит коды деталей в одном столбце с образцами в ячейках B3: B6 (заголовок в B2). Столбцы G-H зарезервированы для результатов. Лист «Поставщики» содержит уникальный список поставщиков в одной колонке (B3: B6). Вы можете указать имена листов и диапазоны для ввода и вывода в подмножестве RunMain().
Для удобства, я жестко закодировал имена листов в некоторых местах. Вы должны вывести их на поверхность в качестве аргументов. Код несколько подробный, чтобы его было легко понять.
Я не тестировал производительность, так как у меня нет набора данных и ожидаю, что вы будете запускать это нечасто. Я добавил только тривиальное количество обработки ошибок.
Полный комплект кода приведен ниже. Вы найдете подменю RunMain() рядом со дном. Это приводит к отключению элемента Main(), который управляет рабочим процессом.
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
Hello. Пожалуйста, укажите соответствующий код, который вы используете для вашего текущего поиска. – Vegard
Кажется, что вам нужна одна из двух вещей - 1- очень сложный бит кода VBA, который вы действительно должны были начать делать самостоятельно, прежде чем задавать здесь 2- машинное обучение, что не совсем (для моего знание) хорошо подходит для использования в VBA – danl
@ danl Обычно я старался и работал над чем-то, прежде чем спрашивать здесь, но я не мог придумать, как получить его с земли. Мои знания о VBA в основном делают однообразные задачи более быстрыми, в отличие от создания динамических инструментов. Я думаю, что машинное обучение было бы полезно да, но это намного выше всего, что я сделал до сих пор. –