Матч частичной текстовой строки (90%) двух столбцов в двух разных листах

Question

Я пытаюсь сопоставить (90%) частичную текстовую строку из столбца листа с другим столбцом листа и принести конечный результат в столбец главного листа. Я нашел решение VBA, но у меня есть некоторые проблемы с этим. 1) соответствие точного текста 2) поиск проблемы для соответствия двух разных столбцов листа.

Пожалуйста, помогите мне разобраться.

Sub lookup() 
Dim TotalRows As Long 
Dim rng As Range 
Dim i As Long 

'Copy lookup values from sheet1 to sheet3 
Sheets("BANK STATEMENT ENTRY").Select 
TotalRows = ActiveSheet.UsedRange.Rows.Count 
Range("F3:F" & TotalRows).Copy Destination:=Sheets("TEST").Range("A1") 

'Go to the destination sheet 
Sheets("TEST").Select 

For i = 1 To TotalRows 
    'Search for the value on sheet2 
    Set rng = Sheets("INFO").UsedRange.Find(Cells(i, 1).Value) 
    'If it is found put its value on the destination sheet 
    If Not rng Is Nothing Then 
     Cells(i, 2).Value = rng.Value 
    End If 
Next 
End Sub 

Answer 1

Я сделал горнодобывающий текст проекта, и я знаю, что вы не можете использовать этот подход, вы должны разбить строки на подстроки, а затем анализировать их. Это будет целый проект, но вам повезло, так как я сделал это за вас.

Давайте упростим проблему и скажем, что у вас есть два диапазона строк, и вы хотите найти все похожие строки между двумя группами. Кроме того, вы хотите иметь допуск для минимизации совпадающих пар.

Предположим, ABCDE и 12BCD00. У них есть B, C, D, BC, CD и BCD. Таким образом, самая длинная общая подстрока - это BCD, которая составляет 3 символа: 3/длина ABCDE (5) будет иметь 60% сходство с первой строкой и 3/7 = 43% сходства. Поэтому, если вы можете получить список всех этих общих подстрок среди всех строк в двух диапазонах, вы можете найти лучший список для фильтрации и получения того, что вы хотите.

Я написал кучу функций. Чтобы использовать его легко, просто скопируйте и вставьте обе группы строк в один лист и создайте окончательный отчет на том же листе, чтобы понять, как он работает.

Функция FuzzyFind, находит все обычные подстроки и дает вам 1-ю строку из Group1/range1, 2-й строки из группы2/range2, общую подстроку и проценты сходства для обеих строк. Хорошо, что вы можете рассказать о функции, насколько малы вы хотите подстроки, например. в предыдущем примере, если вы скажете iMinCommonSubLength = 3, это даст вам только BCD, если вы скажете iMinCommonSubLength = 2, он даст вам BC, CD и BCD и так далее.

Использование функции Main. Я также включил тест sub.

Функции:

Sub TestIt() 
    Call Main(ActiveSheet.Range("A1:A10"), ActiveSheet.Range("B1:B10"), 4, ActiveSheet.Range("D1")) 
End Sub 

Sub Main(rng1 As Range, rng2 As Range, iMinCommonSubLength As Integer, Optional rngReportUpperLeftCell As Range) 
    Dim arr() As Variant 
    Dim rngReport As Range 

    If rngReport Is Nothing Then Set rngReport = ActiveSheet.Range("A1") 

    arr = FuzzyFind(rng1, rng2, iMinCommonSubLength) 
    Set rngReport = rngReportUpperLeftCell.Resize(UBound(arr, 1), UBound(arr, 2)) 

    rngReport.Value = arr 
    rngReport.Columns(1).NumberFormat = "@" 
    rngReport.Columns(2).NumberFormat = "@" 
    rngReport.Columns(3).NumberFormat = "@" 
    rngReport.Columns(4).NumberFormat = "0%" 
    rngReport.Columns(5).NumberFormat = "0%" 
End Sub 

Function GetCharacters(str As String) As Variant 
    Dim arr() As String 
    ReDim arr(Len(str) - 1) 
    For i = 1 To Len(str) 
     arr(i - 1) = Mid$(UCase(str), i, 1) 
    Next 
    GetCharacters = arr 
End Function 


Function GetIterations(iStringLength As Integer, iSubStringLength As Integer) As Integer 

    If iStringLength >= iSubStringLength Then 
     GetIterations = iStringLength - iSubStringLength + 1 
    Else 
     GetIterations = 0 
    End If 
End Function 


Function GetSubtrings(str As String, iSubLength As Integer) As Variant 
    Dim i As Integer 
    Dim count As Integer 
    Dim arr() As Variant 

    count = GetIterations(Len(str), iSubLength) 
    ReDim arr(1 To count) 

    For i = 1 To count 
     arr(i) = Mid(str, i, iSubLength) 
    Next i 

    GetSubtrings = arr() 
End Function 

Function GetLongestCommonSubStrings(str1 As String, str2 As String, iMinCommonSubLeng As Integer) 
    Dim i As Integer 
    Dim iLongestPossible As Integer 
    Dim iShortest As Integer 

    Dim arrSubs() As Variant 

    Dim arr1() As Variant 
    Dim arr2() As Variant 

    ReDim arrSubs(1 To 1) 

    'Longest possible common substring length is the smaller string's length 
    iLongestPossible = IIf(Len(str1) > Len(str2), Len(str2), Len(str1)) 

    If iLongestPossible < iMinCommonSubLeng Then 
     'MsgBox "Minimum common substring length is larger than the shortest string." & _ 
     ' " You have to choose a smaller common length", , "Error" 
    Else 
     'We will try to find the first match of common substrings of two given strings, exit after the first match 
     For i = iLongestPossible To iMinCommonSubLeng Step -1 
      arr1 = GetSubtrings(str1, i) 
      arr2 = GetSubtrings(str2, i) 
      ReDim arrSubs(1 To 1) 
      arrSubs = GetCommonElement(arr1, arr2) 

      If arrSubs(1) <> "" Then Exit For 'if you want JUST THE LONGEST MATCH, comment out this line 
     Next i 
    End If 

    GetLongestCommonSubStrings = arrSubs 
End Function 

Function GetCommonElement(arr1() As Variant, arr2() As Variant) As Variant 
    Dim i As Integer 
    Dim j As Integer 
    Dim count As Integer 
    Dim arr() As Variant 

    count = 1 
    ReDim arr(1 To count) 

    For i = 1 To UBound(arr1) 
     For j = 1 To UBound(arr2) 
      If arr1(i) = arr2(j) Then 
       ReDim Preserve arr(1 To count) 
       arr(count) = arr1(i) 
       count = count + 1 
      End If 
     Next j 
    Next i 

    GetCommonElement = arr 
End Function 

Function FuzzyFind(rng1 As Range, rng2 As Range, iMinCommonSubLength As Integer) As Variant 
    Dim count As Integer 
    Dim i As Integer 
    Dim arrSubs As Variant 
    Dim str1 As String 
    Dim str2 As String 
    Dim cell1 As Range 
    Dim cell2 As Range 
    Dim rngReport As Range 
    Dim arr() As Variant 'array of all cells that are partially matching, str1, str2, common string, percentage 

    count = 1 
    ReDim arr(1 To 5, 1 To count) 

    For Each cell1 In rng1 
     str1 = UCase(CStr(cell1.Value)) 
     If str1 <> "" Then 
      For Each cell2 In rng2 
       str2 = UCase(CStr(cell2.Value)) 
       If str2 <> "" Then 
        ReDim arrSubs(1 To 1) 
        arrSubs = GetLongestCommonSubStrings(str1, str2, iMinCommonSubLength) 
        If arrSubs(1) <> "" Then 
         For i = 1 To UBound(arrSubs) 
          arr(1, count) = cell1.Value 
          arr(2, count) = cell2.Value 
          arr(3, count) = arrSubs(i) 
          arr(4, count) = Len(arrSubs(i))/Len(str1) 
          arr(5, count) = Len(arrSubs(i))/Len(str2) 
          count = count + 1 
          ReDim Preserve arr(1 To 5, 1 To count) 
         Next i 
        End If 
       End If 
      Next cell2 
     End If 
    Next cell1 

    FuzzyFind = TransposeArray(arr) 

End Function 


Function TransposeArray(arr As Variant) As Variant 
    Dim arrTemp() As Variant 
    ReDim arrTemp(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1)) 
    For a = LBound(arr, 2) To UBound(arr, 2) 
    For b = LBound(arr, 1) To UBound(arr, 1) 
     arrTemp(a, b) = arr(b, a) 
    Next b 
    Next a 
    TransposeArray = arrTemp 
End Function  

Не забудьте очистить лист перед созданием новых отчетов. Вставьте таблицу и используйте ее автофильтр, чтобы легко фильтровать ваши вещи.

последнее, но не менее важное: не забудьте нажать на галочку, чтобы объявить об этом как ответе на ваш вопрос.