Поиск шаблонов: определите часть строки, которая является общей для группы ячеек

Question

Я не знаю, как искать это или как объяснить без примера.

Я ищу функцию Excel, которая сравнивает строки ячеек и определяет их общую часть.

Условия

• Сравнивает 2 или более ячеек.
• Общая строка идентифицируется, если ее разделяют 2 ячейки.* (т.е.: если сравнивать более 2, достаточно иметь 2 ячейки с этой строкой. Не все сравниваемые ячейки должны иметь ее.) *
• В строке есть как минимум 3 или более символов, чтобы избежать одиночногоотмеченные символы и пары.

Пример

----------------------------------------------------------------------
|  Pattern  | Page URL 1           | Page URL 2     | Page URL 3     |
----------------------------------------------------------------------
|    test   | example.net/test/    | www.test.com   | www.notest.com |  
----------------------------------------------------------------------
|   q=age   | another.com?q=age    | test.com/q=age | test.com/q=lol |
----------------------------------------------------------------------

Вероятно, на данный момент очевидно, но я пытаюсь достичь / проанализировать, если есть строковые шаблоны, которые являются общими длябольшие наборы URL.

(простите за мою неудачную попытку нарисовать таблицу)

Answer 1

Скопируйте следующий код в модуль.Прочитайте комментарии вверху CommonString для использования.

Option Explicit

Public Function CommonString(rng As Range, iMinLen As Integer, Optional strDelimiter As String = ",") As String
    'Finds the maximum number of cells (iMax) in "rng" that have a common substring of length at least "iMinLen".
    'The function returns a string with the format "iMax: substring1,substring2,substring3..."
    ' where substring1, substring2, etc. are unique substrings found in exactly iMax cells.
    'The output does not include any substrings of the unique substrings.
    'The delimter between substrings can be specified by the optional parameter "strDelimiter".
    'If no common substrings of length at least "iMinLen" are found, "CommonString" will return an empty string.
    Dim blnRemove() As Boolean
    Dim dicSubStrings As Object 'records the number of times substrings are found in pairwise string comparisons
    Dim iCandidates As Integer
    Dim iCol As Integer
    Dim iCurrCommon As Integer
    Dim iCurrLen As Integer
    Dim iMax As Integer
    Dim iMaxCommon As Integer
    Dim iNumStrings As Integer
    Dim iOutCount As Integer
    Dim iRow As Integer
    Dim iString1 As Integer
    Dim iString2 As Integer
    Dim iSubStr1 As Integer
    Dim iSubStr2 As Integer
    Dim lngSumLen As Long
    Dim str1D() As String
    Dim strCandidates() As String
    Dim strOut() As String
    Dim strSim() As String
    Dim strSub As String
    Dim vKey As Variant
    Dim vStringsIn() As Variant

    Set dicSubStrings = CreateObject("Scripting.Dictionary")
    vStringsIn = rng.Value
    iNumStrings = Application.CountA(rng)
    ReDim str1D(1 To iNumStrings)
    ' pull the strings into a 1-D array
    For iRow = 1 To UBound(vStringsIn, 1)
        For iCol = 1 To UBound(vStringsIn, 2)
            iCurrLen = Len(vStringsIn(iRow, iCol))

            If iCurrLen > 0 Then
                iString1 = iString1 + 1
                str1D(iString1) = vStringsIn(iRow, iCol)
                lngSumLen = lngSumLen + iCurrLen
            End If
        Next iCol
    Next iRow
    'initialize the array that will hold the substrings to output
    ReDim strOut(1 To lngSumLen - iNumStrings * (iMinLen - 1))
    'find common substrings from all pairwise combination of strings
    For iString1 = 1 To iNumStrings - 1
        For iString2 = iString1 + 1 To iNumStrings
            strSim = Sim2Strings(str1D(iString1), str1D(iString2), iMinLen)
            'loop through all common substrings
            For iSubStr1 = 1 To UBound(strSim)
                If dicSubStrings.Exists(strSim(iSubStr1)) Then
                    iCurrCommon = dicSubStrings(strSim(iSubStr1)) + 1
                    dicSubStrings(strSim(iSubStr1)) = iCurrCommon
                    If iCurrCommon > iMaxCommon Then iMaxCommon = iCurrCommon
                Else    'add common substrings to the "dicSubStrings" dictionary
                    dicSubStrings.Add strSim(iSubStr1), 1
                    If iMaxCommon = 0 Then iMaxCommon = 1
                End If
            Next iSubStr1
        Next iString2
    Next iString1

    If dicSubStrings.Count = 0 Then Exit Function
    ReDim strCandidates(1 To dicSubStrings.Count)
    'add the candidate substrings to the "strCandidates" array
    'candidate substrings are those found in exactly "iMaxCommon" pairwise comparisons
    For Each vKey In dicSubStrings.keys
        If dicSubStrings(vKey) = iMaxCommon Then
            iCandidates = iCandidates + 1
            strCandidates(iCandidates) = CStr(vKey)
        End If
    Next vKey

    ReDim blnRemove(1 To iCandidates)
    iOutCount = iCandidates
    'keep only the candidate substrings that are not a substring within another candidate substring
    For iSubStr1 = 1 To iCandidates - 1
        If Not blnRemove(iSubStr1) Then
            For iSubStr2 = 1 To iCandidates - 1
                If Not blnRemove(iSubStr2) Then
                    If Len(strCandidates(iSubStr1)) <> Len(strCandidates(iSubStr2)) Then
                        If Len(strCandidates(iSubStr1)) > Len(strCandidates(iSubStr2)) Then
                            If InStr(strCandidates(iSubStr1), strCandidates(iSubStr2)) > 0 Then
                                blnRemove(iSubStr2) = True
                                iOutCount = iOutCount - 1
                            End If
                        Else
                            If InStr(strCandidates(iSubStr2), strCandidates(iSubStr1)) > 0 Then
                                blnRemove(iSubStr1) = True
                                iOutCount = iOutCount - 1
                            End If
                        End If
                    End If
                End If
            Next iSubStr2
        End If
    Next iSubStr1

    ReDim strOut(1 To iOutCount)
    iOutCount = 0
    'add the successful candidates to "strOut"
    For iSubStr1 = 1 To iCandidates
        If Not blnRemove(iSubStr1) Then
            iOutCount = iOutCount + 1
            strOut(iOutCount) = strCandidates(iSubStr1)
        End If
    Next iSubStr1
    'convert "iMaxCommon" (pairwise counts) to number of cells (iMax) by solving the formula:
    '(iMax ^ 2 - iMax) / 2 = iMaxCommon
    iMax = ((8 * iMaxCommon + 1) ^ 0.5 + 1) / 2
    CommonString = iMax & ": " & Join(strOut, strDelimiter)
End Function

Private Function Sim2Strings(str1 As String, str2 As String, iMinLen As Integer) As String()
    'Returns a list of unique substrings common to both "str1" and "str2" that
    ' have a length of at least "iMinLen".
    Dim dicInList As Object
    Dim iCharFrom As Integer
    Dim iLen1 As Integer
    Dim iSearchLen As Integer
    Dim iSubStr As Integer
    Dim strCurr As String
    Dim strList() As String
    Dim vKey As Variant

    iLen1 = Len(str1)
    Set dicInList = CreateObject("Scripting.Dictionary")
    'add common substrings to the "dicInList" dictionary
    For iCharFrom = 1 To iLen1 - iMinLen + 1
        For iSearchLen = iMinLen To iLen1 - iCharFrom + 1
            strCurr = Mid(str1, iCharFrom, iSearchLen)

            If InStr(str2, strCurr) = 0 Then
                Exit For
            Else
                If Not dicInList.Exists(strCurr) Then
                    dicInList.Add strCurr, 0
                End If
            End If
        Next iSearchLen
    Next iCharFrom

    If dicInList.Count = 0 Then
        ReDim strList(0)
    Else
        ReDim Preserve strList(1 To dicInList.Count)
        'output the keys in the "dicInList" dictionary to the "strList" array
        For Each vKey In dicInList.keys
            iSubStr = iSubStr + 1
            strList(iSubStr) = vKey
        Next vKey
    End If

    Sim2Strings = strList
End Function

Answer 2

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

Public Sub FindStrings()
    Dim rng1 As Excel.Range
    Dim rng2 As Excel.Range

    Set rng1 = ActiveSheet.Range("A1")
    Set rng2 = ActiveSheet.Range("A2")

    Dim i As Integer
    Dim j As Integer
    Dim searchVal As String
    For i = 3 To Len(rng2)
        For j = 1 To Len(rng1)
            searchVal = Mid(rng1, j, i)
            If Len(searchVal) < i Then Exit For
            If InStr(1, rng2, searchVal) Then Debug.Print searchVal
        Next j
    Next i
End Sub

В ячейку A1 поместите example.net / test
В ячейку A2 поместите www.test.com

Результат

tes
est
test

ОБНОВЛЕНИЕ

Я обновил код, чтобы найти минимум4 символа вместо 3 (как вы упомянули выше).Кроме того, я догадался, что вы не захотите возвращать строки, такие как www. и .com, а также строки с символом / или ..Так что код вытягивает их.Кроме того, он сравнивает каждую комбинацию столбцов.

Option Explicit
Public Sub CompareStrings()
    Dim Arr As Variant
    Dim i As Integer
    Dim j As Integer
    Dim StartRange As Excel.Range
    Dim SearchRange As Excel.Range
    Dim Counter As Integer
    Dim ComparableRange As Variant
    Dim Comparable As Integer
    Dim Compared As Integer
    Dim SearchVal As String

    Set StartRange = ActiveSheet.Range("A1")

    Counter = 0
    For Each ComparableRange In ActiveSheet.Range("A1:A2")
    Set SearchRange = Range(StartRange.Offset(Counter), Cells(StartRange.Offset(Counter).Row, Columns.Count).End(xlToLeft))
    Arr = Application.Transpose(Application.Transpose(SearchRange.Value))
    Debug.Print "Row " & SearchRange.Row & ":"
        For j = LBound(Arr) To UBound(Arr)
            For i = j + 1 To UBound(Arr)
                For Comparable = 4 To Len(Arr(j))
                    For Compared = 1 To Len(Arr(i))
                        SearchVal = Mid(Arr(j), Compared, Comparable)
                        If InStr(1, SearchVal, ".") = 0 Then
                            If InStr(1, SearchVal, "/") = 0 Then
                                If Len(SearchVal) < Comparable Then Exit For
                                If InStr(1, Arr(i), SearchVal) > 0 Then Debug.Print vbTab & SearchVal
                            End If
                        End If
                    Next Compared
                Next Comparable
            Next i
        Next j
        Counter = Counter + 1
    Next ComparableRange    
End Sub

При сравнении test.com/q=age с another.com?q=age Вы все равно получите такие результаты, как:

q=ag
=age 
q=age 

... хотя я подозреваю васхочу только третий.Чем длиннее соответствующие строки, тем больше результатов вы получите.Последние результаты, которые вы, вероятно, захотите.