Есть такая задача: найти в столбике D ячейку и сравнить её с остальными ячейками в этом же столбике на совпадение текста(в процентном соотношении). Дальше необходимо полученный процент поставить в найденной строке в столбик М. Например берем ячейку D36 и сравниваем со всеми ячейками в столбике D. Допустим совпадение текста D36 и D75 40%. Эту цифру мы вставляем в ячейку М75.

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


Sub ÄÆÊÕ()
'
' Ìàêðîñ íà ñðàâíåíèå òåêñòà
'

Dim Svp, lr, i&
lr = Cells(Rows.Count, 4).End(xlUp).Row 'ïîñëåäíÿÿ ñòðîêà
Svp = [a2].CurrentRegion.Columns(4).Value ' ìàññèâ äàííûõ äî ïîñëåäíåé ñòðîêè

For i = 1 To UBound(Svp) ' öèêë ïî ìàññèâó
If Cells.InterColor = vbYellow Then ' åñëè ÿ÷åéêà æåëòàÿ òî äåéñòâèå âûïîëíÿåòñÿ
    Dim s1 As String, mass As Range
    Dim as1, as2, l1 As Long, l2 As Long, lr As Long
    Dim asStr2
    Dim s As String, s2 As String, lp, lTmpCom As Long, lResCom As Long
    Dim lResR As Long, sResS As String, v
   
    as1 = Split(s1, sDelim)
    asStr2 = mass.Value
    If Not IsArray(asStr2) Then ReDim asStr2(1 To 1, 1 To 1): asStr2(1, 1) = mass.Value

    For lr = 1 To UBound(asStr2, 1)
        as2 = Split(asStr2(lr, 1), sDelim)
        lResCom = 0
        For l1 = LBound(as1) To UBound(as1)
            s = as1(l1)
            For l2 = LBound(as2) To UBound(as2)
                If as2(l2) = s Then
                    lResCom = lResCom + 1
                    Exit For
                End If
            Next l2
        Next l1
        If lTmpCom < lResCom Then
            lTmpCom = lResCom
            lResR = lr
            sResS = asStr2(lr, 1)
            lp = lp + 1
        End If
    Next lr
    v = (lTmpCom / (UBound(as1) + 1)) * 100
    Cell(Svp, 13) = v

   
End Sub


Дальше в идеале нужно было сделать отборку и первые 10 строк с максимальным совпадением переместить на другой лист, но эту часть кода я пока не сделала(уже сделанное не работает). Если эту отборку можно сделать вируально, без исправлений в файле, то подскажите этот вариант,пожалуйста.

и третий вариант на эту же тему, но этот уже полурабочий...
Function QuickEquality(ByVal t1, ByVal t2) As Single ' Ïîõîæåñòü ГЇГ® Г*Г*Г·Г*Г«Г*Г¬ ñëîâ
    Dim i%, j%, k%, S, Z, L%, N1%, N2%
    Dim Max1%(), Max2%(), Sum%
    S = Split(t1, " "): Z = Split(t2, " ")
    N1 = UBound(S): N2 = UBound(Z)
    ReDim Max1(0 To N1), Max2(0 To N2)
    For i = 0 To N1
        L = Len(S(i))
        For j = 0 To N2
            For k = L To IIf(Max1(i) > 2, Max1(i), 2) Step -1
                If Left(S(i), k) = Left(Z(j), k) Then
                    If Max1(i) <= k And Max2(j) <= k Then Max1(i) = k: Max2(j) = k
                    Exit For
                End If
            Next
        Next j
        Sum = Sum + Max1(i)
    Next i
    t1 = Replace$(t1, " ", "")
    t2 = Replace$(t2, " ", "")
    QuickEquality = Sum / IIf(Len(t1) > Len(t2), Len(t1), Len(t2))
End Function

Function Equality(ByVal t1, ByVal t2) As Single ' Г,Г±ГҐ ГЇГ*ðû ñëîâ óãëóáëåГ*Г*Г® Г±Г°Г*ГўГ*ГЁГўГ*ГѕГІГ±Гї
    Dim i%, j%, k%, S, Z, L%, N1%, N2%
    Dim Max1%(), Max2%(), Sum%
    S = Split(t1, " "): Z = Split(t2, " ")
    N1 = UBound(S): N2 = UBound(Z)
    ReDim Max1(0 To N1), Max2(0 To N2)
    For i = 0 To N1
        L = Len(S(i))
        For j = 0 To N2
            k = Shodstvo(S(i), Z(j))
            If Max1(i) <= k And Max2(j) <= k Then Max1(i) = k: Max2(j) = k
        Next j
        Sum = Sum + Max1(i)
    Next i
    t1 = Replace$(t1, " ", "")
    t2 = Replace$(t2, " ", "")
    Equality = Sum / IIf(Len(t1) > Len(t2), Len(t1), Len(t2))
End Function
Function Shodstvo(ByVal t1, ByVal t2) ' Г"ãëóáëåГ*Г*ûé Г*Г*Г*ëèç ïîõîæåñòè ñëîâ
    Dim i%, j%, S1$, S2$, t3$, Len1%, Su1!, Su2!, Nach$, Shablon$, Sha1$, U As Boolean
    t1 = CStr(t1): t2 = CStr(t2)
    If Len(t1) > Len(t2) Then t3 = t1: t1 = t2: t2 = t3
    Len1 = Len(t1)
    Sha1 = "*"
    For i = 1 To Len1
        For j = Len1 - i + 1 To 1 Step -1
            Nach = Mid$(t1, i, j)
            Shablon = Sha1 & Nach & "*"
            If t2 Like Shablon Then
                Su2 = Len(Replace$(Shablon, "*", ""))
                i = i + j - 1
                If Su1 < Su2 Then
                    Su1 = Su2
                    Sha1 = Shablon
                End If
                Exit For
            End If
        Next j
    Next i
    Sha1 = Replace$(Sha1, "*", "")
    Shodstvo = Len(Sha1) ' Гў Г§Г*Г*ГЄГ*Гµ
    'Shodstvo = Len(Sha1)  / Len(t2) ' Гў %%
End Function
Sub ГЊГ*êðîñ_ñîâïГ*äåГ*ГЁГ©1()
   
    Dim Svp, lr, i&, i1
    lr = Cells(Rows.Count, 4).End(xlUp).Row 'ïîñëåäГ*ГїГї ñòðîêГ*
    Svp = [d2].CurrentRegion.Columns(4).Value ' Г¬Г*Г±Г±ГЁГў Г¤Г*Г*Г*ûõ äî ïîñëåäГ*ГҐГ© ñòðîêè
    Svp1 = [d2].CurrentRegion.Columns(4).Value ' Г¬Г*Г±Г±ГЁГў Г¤Г*Г*Г*ûõ äî ïîñëåäГ*ГҐГ© ñòðîêè

    For i = 1 To UBound(Svp) ' öèêë ГЇГ® Г¬Г*Г±Г±ГЁГўГі
    If Cells(i, 4).Interior.Color = vbYellow Then ' åñëè ÿ÷åéêГ* æåëòГ*Гї ГІГ® äåéñòâèå âûïîëГ*ГїГҐГІГ±Гї
        Dim TmpCell As Range ' Г'îçäГ*ВёГ¬ âðåìåГ*Г*ГіГѕ ïåðåìåГ*Г*ГіГѕ TmpCell äëÿ ñîõðГ*Г*ГҐГ*ГЁГї ÿ÷åéêè, ГЄГ*ГЄ îáúåêò ГІГЁГЇГ* Range
        Set TmpCell = Cells(i, 4) ' Г‡Г*ïîìèГ*Г*ГҐГ¬ Г*ГЄГІГЁГўГ*ГіГѕ ÿ÷åéêó
        Dim t1 ' Г'îçäГ*ГҐГ¬ ïåðåìåГ*Г*ГіГѕ äëÿ Г§Г*Г*Г·ГҐГ*ГЁГї ÿ÷åéêè
        t1 = TmpCell.Value
     
        For i1 = 1 To UBound(Svp1) ' öèêë ГЇГ® Г¬Г*Г±Г±ГЁГўГі
     
        Dim t2 ' Г'îçäГ*ГҐГ¬ ïåðåìåГ*Г*ГіГѕ äëÿ Г§Г*Г*Г·ГҐГ*ГЁГї ÿ÷åéêè
        t2 = Cells(i1, 4).Value
       
        Cells(i1, 13).Formula = Equality(t1, t2) * 100
       
       Next
    End If
    Next
End Sub

Код работает...пару строк.И вылетает на строке

If t2 Like Shablon Then

в функции Shodstvo. Помогите преобразовать код, так чтобы он работал.

Кросс:
http://www.excelworld.ru/forum/10-33633-1