Сравнение 2-х столбцов на частичное совпадение

@Зергиус · Регистрация: 02.11.2017

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

Есть макрос, он сравнивает два столбца на частичное совпадение. При сравнении 50 строк справляется быстро, а при 1000 строках выдает ошибку "Overflow". Изменял тип переменных не помогло. В чем может быть проблема?

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
Sub ОдинаковыеСлова()
Dim iLastRow1 As Long
Dim iLastRow2 As Long
Dim i As Long
Dim j As Long
Dim k As Integer
Dim n As Integer
Dim Строка As Variant
Dim ПодСтрока As Variant
Dim ЧислоСлов As Integer
Dim iDict As Object
Dim MyArr As Variant
Dim iMax As Double
    With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
      .DisplayAlerts = False
    End With
 
iLastRow1 = Cells(Rows.Count, 1).End(xlUp).Row
iLastRow2 = Cells(Rows.Count, 2).End(xlUp).Row
        Columns("C:E").ClearContents
    'убираем скобки из столбца В
   With Range("A2:A" & iLastRow2)
       .Replace what:="(", replacement:=""
       .Replace what:=")", replacement:=""
       .Replace what:="\", replacement:=""
   End With
        
ReDim MyArr(1 To iLastRow1 - 1, 1 To iLastRow2 - 1)
 
    For i = 2 To iLastRow1      'цикл по строкам столбца А
      'из анализа в строке столбца А исключаем то, что в скобках
      '(боевик, триллер, криминал, приключения)
        Строка = Split(Split(Trim(Cells(i, 1)), "(")(0), " ")
            ЧислоСлов = UBound(Строка)
            
            Set iDict = CreateObject("scripting.dictionary")
               'заполняем словарь словами из массива Строка
               For k = 0 To UBound(Строка) - 1
                    If Not iDict.Exists(Строка(k)) Then
                        iDict.Add Строка(k), 1
                    End If
               Next
         
         For j = 2 To iLastRow2     'цикл по строкам столбца В
            ПодСтрока = Split(Trim(Cells(j, 2)), " ")
                n = 0
                    ' есть ли слова из подстроки в массиве Строка
               For k = 0 To UBound(ПодСтрока)
                    If iDict.Exists(ПодСтрока(k)) Then
                        n = n + 1
                    End If
               Next
            MyArr(i - 1, j - 1) = n / ЧислоСлов '% совпадения
        Next
    Next
    For i = 1 To iLastRow1 - 1    'ищем максимум совпадения и в какой строке
                iMax = MyArr(i, 1)
        For j = 1 To iLastRow2 - 2
            If MyArr(i, j + 1) > iMax Then
                iMax = MyArr(i, j + 1)
                 Cells(i + 1, 4) = "В строке " & (j + 2) & " столбца В"
                  If iMax >= Range("B1").Value Then Cells(i + 1, 5) = Cells(j + 2, 2)
            End If
        Next
            Cells(i + 1, 3) = iMax
    Next
    
    With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .DisplayAlerts = True
    End With
End Sub

@Казанский · 26.02.2019, 11:18

Сообщение от Зергиус

при 1000 строках выдает ошибку "Overflow"

На какой строке?

Сообщение от Зергиус

Изменял тип переменных не помогло

Каких?
Без файла-примера толку не будет.

Добавлено через 5 минут

Сообщение от Зергиус

23 'убираем скобки из столбца В

А замена идет в столбце А, но ограниченном iLastRow2, т.е. высотой столбца В. А потом в 35 строке делается Split по скобке значений из ст. А. Странно это все

@Зергиус · 26.02.2019, 11:35 **[ТС]**

Сообщение от Казанский

На какой строке?

Он строку не указывает.

Сообщение от Казанский

Каких?

ЧислоСлов, k и n

вот пример
https://cloud.mail.ru/public/Ez9h/44AEKzpZD

@Казанский · 26.02.2019, 11:55

Зергиус, ошибка происходит на строке

Visual Basic
1
55     MyArr(i - 1, j - 1) = n / ЧислоСлов '% совпадения

потому что ЧислоСлов=0. Можно поправить так

Visual Basic
1
 If ЧислоСлов <> 0 Then MyArr(i - 1, j - 1) = n / ЧислоСлов '% совпадения

, повлияет ли это на алгоритм - непонятно.
Еще ошибка происходит при пустой ячейке в А, добавил проверку.

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
Sub ОдинаковыеСлова()
Dim iLastRow1 As Long
Dim iLastRow2 As Long
Dim i As Long
Dim j As Long
Dim k As Integer
Dim n As Integer
Dim Строка As Variant
Dim ПодСтрока As Variant
Dim ЧислоСлов As Integer
Dim iDict As Object
Dim MyArr As Variant
Dim iMax As Double
    With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
      .DisplayAlerts = False
    End With
 
iLastRow1 = Cells(Rows.Count, 1).End(xlUp).Row
iLastRow2 = Cells(Rows.Count, 2).End(xlUp).Row
        Columns("C:E").ClearContents
    'убираем скобки из столбца В
   ' With Range("A2:A" & iLastRow2)
  '      .Replace what:="(", replacement:=""
   '     .Replace what:=")", replacement:=""
   '     .Replace what:="\", replacement:=""
  '  End With
        
ReDim MyArr(1 To iLastRow1 - 1, 1 To iLastRow2 - 1)
 
    For i = 2 To iLastRow1      'цикл по строкам столбца А
      'из анализа в строке столбца А исключаем то, что в скобках
      '(боевик, триллер, криминал, приключения)
      If Len(Cells(i, 1)) Then
        Строка = Split(Split(Trim(Cells(i, 1)), "(")(0), " ")
            ЧислоСлов = UBound(Строка)
            
            Set iDict = CreateObject("scripting.dictionary")
               'заполняем словарь словами из массива Строка
               For k = 0 To UBound(Строка) - 1
                    If Not iDict.Exists(Строка(k)) Then
                        iDict.Add Строка(k), 1
                    End If
               Next
         
         For j = 2 To iLastRow2     'цикл по строкам столбца В
            ПодСтрока = Split(Trim(Cells(j, 2)), " ")
                n = 0
                    ' есть ли слова из подстроки в массиве Строка
               For k = 0 To UBound(ПодСтрока)
                    If iDict.Exists(ПодСтрока(k)) Then
                        n = n + 1
                    End If
               Next
            If ЧислоСлов <> 0 Then MyArr(i - 1, j - 1) = n / ЧислоСлов '% совпадения
        Next
      End If
    Next
    For i = 1 To iLastRow1 - 1    'ищем максимум совпадения и в какой строке
                iMax = MyArr(i, 1)
        For j = 1 To iLastRow2 - 2
            If MyArr(i, j + 1) > iMax Then
                iMax = MyArr(i, j + 1)
                 Cells(i + 1, 4) = "В строке " & (j + 2) & " столбца В"
                  If iMax >= Range("B1").Value Then Cells(i + 1, 5) = Cells(j + 2, 2)
            End If
        Next
            Cells(i + 1, 3) = iMax
    Next
    
    With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .DisplayAlerts = True
    End With
End Sub

@Зергиус · 26.02.2019, 12:00 **[ТС]**

Большое спасибо, все заработало.

Новые блоги и статьи Все статьи Все блоги /
Как дизайн сайта влияет на конверсию: 7 решений, которые реально повышают заявки Neotwalker 08.03.2026 Многие до сих пор воспринимают дизайн сайта как “красивую оболочку”. На практике всё иначе: дизайн напрямую влияет на то, оставит человек заявку или уйдёт через несколько секунд. Даже если у вас. . .	Модульная разработка через nuget packages DevAlt 07.03.2026 Сложившийся в . Net-среде способ разработки чаще всего предполагает монорепозиторий в котором находятся все исходники. При создании нового решения, мы просто добавляем нужные проекты и имеем. . .	Модульный подход на примере F# DevAlt 06.03.2026 В блоге дяди Боба наткнулся на такое определение: В этой книге («Подход, основанный на вариантах использования») Ивар утверждает, что архитектура программного обеспечения — это структуры,. . .	Управление камерой с помощью скрипта OrbitControls.js на Three.js: Вращение, зум и панорамирование 8Observer8 05.03.2026 Содержание блога Финальная демка в браузере работает на Desktop и мобильных браузерах. Итоговый код: orbit-controls-threejs-js. zip. Сканируйте QR-код на мобильном. Вращайте камеру одним пальцем,. . .
SDL3 для Web (WebAssembly): Синхронизация спрайтов SDL3 и тел Box2D 8Observer8 04.03.2026 Содержание блога Финальная демка в браузере. Итоговый код: finish-sync-physics-sprites-sdl3-c. zip На первой гифке отладочные линии отключены, а на второй включены:. . .	SDL3 для Web (WebAssembly): Идентификация объектов на Box2D v3 - использование userData и событий коллизий 8Observer8 02.03.2026 Содержание блога Финальная демка в браузере. Итоговый код: finish-collision-events-sdl3-c. zip Сканируйте QR-код на мобильном и вы увидите, что появится джойстик для управления главным героем. . . .	Реалии Hrethgir 01.03.2026 Нет, я не закончил до сих пор симулятор. Эта задача сложнее. Не получилось уйти в плавсостав, но оно и к лучшему, возможно. Точнее получалось - но сварщиком в палубную команду, а это значит, в моём. . .	Ритм жизни kumehtar 27.02.2026 Иногда приходится жить в ритме, где дел становится всё больше, а вовлечения в происходящее — всё меньше. Плотный график не даёт вниманию закрепиться ни на одном событии. Утро начинается с быстрых,. . .

@Зергиус 0 / 0 / 0 Регистрация: 02.11.2017 Сообщений: 3
	26.02.2019, 12:00 [ТС]
	Большое спасибо, все заработало. 0

Сравнение 2-х столбцов на частичное совпадение

Решение