Есть такая задача: найти в столбике 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