Профессиональные приемы работы в Microsoft Excel

Пожалуйста, войдите или зарегистрируйтесь.


Расширенный поиск  

Новости:

Прикрепить к сообщению можно только файлы xls, gif, jpg, rar, zip,7z, bas, frm, cls, doc размером до 150 Кб.

Автор Тема: Макрос сравнения текста в массиве  (Прочитано 346 раз)

0 Пользователей и 1 Гость просматривают эту тему.

Екатерина Максимова

  • Пользователь
  • **
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 19

Есть такая задача: найти в столбике 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 строк с максимальным совпадением переместить на другой лист, но эту часть кода я пока не сделала(уже сделанное не работает). Если эту отборку можно сделать вируально, без исправлений в файле, то подскажите этот вариант,пожалуйста.
Записан

Екатерина Максимова

  • Пользователь
  • **
  • Уважение: +0/-0
  • Оффлайн Оффлайн
  • Сообщений: 19
Re: Макрос сравнения текста в массиве
« Ответ #1 : 08.05.2017, 14:34:44 »

и третий вариант на эту же тему, но этот уже полурабочий...
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. Помогите преобразовать код, так чтобы он работал.
Записан

kuklp1

  • Пользователь
  • **
  • Уважение: +5/-0
  • Оффлайн Оффлайн
  • Сообщений: 82
Записан
Я, как всегда, чертовски адекватен… Email: kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728, E332314026771
 



Темы без ответов

17.08.2017 12:15 Гиперссылка и фильтр одновременно макрос 29
17.08.2017 08:29 Расчет работы сотрудника после основного рабочего времени 43
13.06.2017 00:27 Сводная таблица: как не вручную отсортировать в опред. порядке (не Custom List) 342
23.05.2017 11:20 Копирование данных из одной таблицы в умную таблицу по условию 727
18.05.2017 15:45 Не работает гиперссылка при копировании. 388
15.03.2017 15:45 автозамена картинок PowerPoint 636
13.03.2017 07:09 Использование базы КЛАДР в exel 955
11.03.2017 13:43 Изменить нумерацию страниц 851
10.03.2017 08:40 Как делать бекапы гугл таблицы? 720
18.02.2017 11:31 Изменить ввод данных помогите...из столбца в таблицу. 933





Яндекс цитирования msexcel.ru Яндекс.Метрика

Страница сгенерирована за 0.049 секунд. Запросов: 27.