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

@Makroshka · Регистрация: 26.09.2016

Студворк — интернет-сервис помощи студентам

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

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

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
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 строк с максимальным совпадением переместить на другой лист, но эту часть кода я пока не сделала(уже сделанное не работает). Если эту отборку можно сделать вируально, без исправлений в файле, то подскажите этот вариант,пожалуйста.
P.S. Так как загрузить можно файл не больше 100 кб, то файл во вложении ОЧЕНЬ обрезан и совпадения на нем могут быть минимальны

SoftIce · 07.05.2017, 21:40

Сообщение от Makroshka

На данный момент проблема в пункте 3 и я не понимаю как это указать.

Перебирать в цикле ячейки диапазона.

Добавлено через 10 минут
Можно сделать так по вашему описанию, только при чем тут "совпадение текста" ?

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
'........
'........
    Dim Zn As Variant
    Zn = TmpCell.Value
 
     
     Dim c As Variant, v
     For Each c In Range("D2:D100")
        If Val(c) <> 0 Then
           v = Zn / Val(c) * 100
           Cells(c.Row, 13) = v
         End If
     Next c

@Hugo121 · 07.05.2017, 22:05

Упс, извиняюсь - проглядел: так нельзя!

Visual Basic
1
Val1 = Svp(i, 4).Value

а вот так можно:

Visual Basic
1
Val1 = Svp(i, 4)

Но уже вероятно ненужно...
Потому что Value есть у ячейки, но не у массива.

@Makroshka · 07.05.2017, 22:16 **[ТС]**

Нашла еще один вариант, но опять таки не все ладно:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
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 = ActiveCell ' Çàïîìèíàåì àêòèâíóþ ÿ÷åéêó
        Dim t1 ' Ñîçäàåì ïåðåìåííóþ äëÿ çíà÷åíèÿ ÿ÷åéêè
        t1 = TmpCell.Value
     
        For i1 = 1 To UBound(Svp1) ' öèêë ïî ìàññèâó
     
        Dim t2 ' Ñîçäàåì ïåðåìåííóþ äëÿ çíà÷åíèÿ ÿ÷åéêè
        t2 = Cells(i1, 4).Value
        
        Cell(i1, 13).Formula = " & Equality(t1, t2) * 100"
 
        
    
        Next
    End If
    Next
End Sub

код тормозит на строке

Visual Basic
1
Cell(i1, 13).Formula = " & Equality(t1, t2) * 100"

Я как-то неправильно указываю куда надо вставлять значение функции?

@Hugo121 · 07.05.2017, 22:20

Выделите ячейку с формулой, в окне отладки наберите

Visual Basic
1
?selection.formula

и Enter - увидите как должна выглядеть эта формула в макросе (какая должна быть строка).

@Makroshka · 07.05.2017, 22:44 **[ТС]**

Спасибо, помогло. Теперь подскажите почему возмущается код в функции

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
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 = ActiveCell ' Çàïîìèíàåì àêòèâíóþ ÿ÷åéêó
        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

на строке

Visual Basic
1
If t2 Like Shablon Then

в функции Shodstvo.

@MonaxGT · 15.06.2017, 14:15

Добрый день!
Удалось ли найти в чем проблема?

@Makroshka · 15.06.2017, 16:33 **[ТС]**

К сожалению нет...пришлось использовать другой код...

Новые блоги и статьи Все статьи Все блоги /
[golang] Алгоритм «Хак Госпера» alhaos 17.05.2026 Алгоритм «Хак Госпера» Хак Госпера (Gosper's Hack) — алгоритм нахождения следующего по величине числа с тем же количеством установленных бит. Придуман Биллом Госпером в 1970-х, опубликован в. . .	Рисование бинарного древа до 6-го колена на js, svg. russiannick 17.05.2026 <svg width="335" height="240" viewBox="0 0 335 240" fill="#e5e1bb"> <style> <!]> </ style> <g id="bush"> </ g> </ svg> function fn(){ let rost;/ / высота древа let xx=165,yy=210,w=256;	FSharp: interface of module DevAlt 16.05.2026 Интерфейс модуля F# позволяет управлять доступностью членов, содержащихся в реализации модуля. По-умолчанию все члены модуля доступны: module Foo let x = 10 let boo () = printfn "boo" . . .	Хитросплетение родственных связей пантеона греческих богов. russiannick 14.05.2026 Однооконник, позволяющий узреть и изучить отдельных героев древней Греции. <!DOCTYPE html> <html lang="ru"> <head> <meta charset="UTF-8"> <meta http-equiv="X-UA-Compatible". . .
[golang] Угол между стрелками часов alhaos 12.05.2026 По заданным значениям часа и минуты необходимо определить значение меньшего угла между стрелками аналогового циферблата часов. import "math" func angleClock(hour int, minutes int) float64 { . . .	Debian 13: Установка Lazarus QT5 ВитГо 09.05.2026 Эта инструкция моя компиляция инструкций volvo https:/ / www. cyberforum. ru/ blogs/ 203668/ 10753. html и его же старой инструкции по установке Lazarus с gtk2. . .	Нейросеть на алгоритме "эстафета хвоста" как перспектива. Hrethgir 06.05.2026 На десерт, когда запущу сервер. Статья тут https:/ / habr. com/ ru/ articles/ 1030914/ . Автор я сам, нейросеть только помогает в вопросах которые мне не известны - не знаю людей которые знали-бы. . .	Асинхронный приём данных из COM-порта Argus19 01.05.2026 Асинхронный приём данных из COM-порта Купил на aliexpress термопринтер QR701. Он оказался странным. Поключил к Arduino Nano. Был очень удивлён. Наотрез отказывается печатать русские буквы. Чтобы. . .

@MonaxGT 278 / 278 / 25 Регистрация: 02.08.2012 Сообщений: 1,232
	15.06.2017, 14:15
	Добрый день! Удалось ли найти в чем проблема? 0

@Makroshka 0 / 0 / 0 Регистрация: 26.09.2016 Сообщений: 164
	15.06.2017, 16:33 [ТС]
	К сожалению нет...пришлось использовать другой код... 0