Сравнение слов и при совпадении, вытаскивание рядом чисел

@carolina199x · Регистрация: 21.04.2023

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

Здравствуйте дорогие специалисты.
Прошу помочь мне справиться с задачей вытаскивания рядом чисел при сравнивании слов в ячейках, чтобы хотя бы при одном совпадении число рядом вытаскивалось.
Я пробовала функцией ВПР, но она до конца не справилась, т.к. сравнивает только 1 ячейку с первой из диапазона, а не диапазон ячеек с диапазоном ячеек.

прикрепила файл с примером, и где я пыталась впр использовать.
там немного описала как должно получиться

@testuser2 · 28.06.2024, 15:08

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

для последнего макроса

Кликните здесь для просмотра всего текста

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
Function FindMatches_(arr1(), arr2(), arr3(), cntMtch&) As Variant() 'v 26.06.24
    Dim row&, clm&, row2&, clm2&, k&, cnt&, clCnt&, ind&, arInd&(), arrOut(), dct As Object
        
    clCnt = UBound(arr3, 2)                              'кол-во столбцов исх. данных
    ReDim arrOut(1 To UBound(arr3), 1 To clCnt)          'результирующий массив
    Set dct = CreateObject("Scripting.Dictionary")       'словарь для поиска совпадений
    ReDim arInd(10000, 1)                                'массив для записи совпадений, их количеств и строк, в которых эти совпадения встретились
    
    For row = 1 To UBound(arr2)
        For clm = 1 To UBound(arr2, 2)
            If Len(arr2(row, clm)) > 0 Then
                If Not dct.Exists(arr2(row, clm)) Then
                    dct.Add arr2(row, clm), row
                Else
                    dct(arr2(row, clm)) = 0
                End If
            End If
        Next
    Next
    
    For row = 1 To UBound(arr1)
        cnt = 0
        For clm = 1 To UBound(arr1, 2)
            If dct.Exists(arr1(row, clm)) Then
                row2 = dct(arr1(row, clm))
                If row2 > 0 Then
                    cnt = cnt + 1
                    If cnt = cntMtch Then
                        For clm2 = 1 To clCnt
                            arrOut(row, clm2) = arr3(row2, clm2)
                        Next
                        Exit For
                    End If
                End If
            End If
        Next
    Next
    
    FindMatches_ = arrOut
End Function

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

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

чтобы при совпадении любого слова по вертикали, вытаскивание не происходило.

Кликните здесь для просмотра всего текста

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
Sub carolina199x4()
    Dim row&, clm&, row2&, frow&, clm2&, k&, lr&, clCnt&, arr1, arr2, arr3, arrOut, dcts() As Object
    
    lr = Columns("DV").Find("*", searchdirection:=xlPrevious).row
    arr1 = Range(Cells(34, "BC"), Cells(lr, "BL")).Value 'массив данных
    arr2 = Range(Cells(34, "DJ"), Cells(lr, "DS")).Value 'массив данных условия
    arr3 = Range(Cells(34, "DY"), Cells(lr, "EI")).Value 'массив искомых данных
    clCnt = UBound(arr3, 2)                              'кол-во столбцов ихк. данных
    
    ReDim arrOut(1 To UBound(arr3), 1 To clCnt)          'результирующий массив
    ReDim dcts(1 To UBound(arr2, 2))                     'словари включающих/исключающих слов
    For k = 1 To UBound(dcts)
        Set dcts(k) = CreateObject("Scripting.Dictionary")
    Next
    For row = 1 To UBound(arr2)
        For clm = 1 To UBound(arr2, 2)
            If Len(arr2(row, clm)) > 0 Then
                If dcts(clm).Exists(arr2(row, clm)) Then
                    k = dcts(clm)(arr2(row, clm))
                    If k Then dcts(clm)(arr2(row, clm)) = 0 'если есть совпадение по столбцу - исключаем
                Else
                    dcts(clm).Add arr2(row, clm), row     'включающее слово
                End If
            End If
        Next
    Next
    
    For row = 1 To UBound(arr1)
        For clm = 1 To UBound(arr1, 2)
            If dcts(clm).Exists(arr1(row, clm)) Then
                row2 = dcts(clm)(arr1(row, clm))
                If row2 <> 0 Then
                    frow = row2
                Else
                    frow = 0
                    Exit For                              'исключение строки
                End If
            End If
        Next
        If frow Then
            For clm2 = 1 To clCnt             'включение строки
                arrOut(row, clm2) = arr3(frow, clm2)
            Next
        End If
        frow = 0
    Next
    
    Range("U34:AE34").Resize(UBound(arr1)).Value = arrOut 'вывод результата
End Sub

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

Сообщение от АЕ

Про внятность я не ошибся

Есть проблемки с этим, не спорю )

@carolina199x · 28.06.2024, 17:27 **[ТС]**

testuser2, Дорогой специалист. Оба макроса работают с ошибкой. Вроде бы работают, но всё таки ошибка, с которой не возможно верно использовать. Нужна небольшая доработка.
Суть ошибки разъяснила в файлах примерах с названиями
FindMatches и carolina199x4
В обоих файлах суть ошибки написала голубым текстом.

@АЕ · 01.07.2024, 20:01

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

Нужна небольшая доработка

Последняя? Борьба лести и не компетентности.

@carolina199x · 01.07.2024, 21:01 **[ТС]**

АЕ,

@carolina199x · 08.06.2025, 01:42 **[ТС]**

testuser2, Здравствуйте, вы мне прошлый раз помогли. и я до сих пор использую ваш макрос.

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
Sub Подставка_СРАВНЕНИЕ_ПО_ПЕРВОЙ_1()
'жёлтый к жёлтому
    Dim row&, clm&, row2&, clm2&, k&, lr&, clCnt&, arr1, arr2, arr3, arrOut, dct
    
    lr = Columns("JO").Find("*", SearchDirection:=xlPrevious).row
    arr1 = Range(Cells(10, "GL"), Cells(lr, "GT")).Value 'массив данных
    arr2 = Range(Cells(10, "IR"), Cells(lr, "JA")).Value 'массив данных условия
    arr3 = Range(Cells(10, "JO"), Cells(lr, "KC")).Value 'массив искомых данных
    clCnt = UBound(arr3, 2)                              'кол-во столбцов ихк. данных
    ReDim arrOut(1 To UBound(arr3), 1 To clCnt)          'результирующий массив
    Set dct = CreateObject("Scripting.Dictionary")       'словарь включающих/исключающих слов
    
    For i = 1 To UBound(arr2)
        For j = 1 To UBound(arr2, 2)
            If Len(arr2(i, j)) > 0 Then
                If Not dct.Exists(arr2(i, j)) Then
                    dct.Add arr2(i, j), i
                End If
            End If
        Next
    Next
    
    For row = 1 To UBound(arr1)
        For clm = 1 To UBound(arr1, 2)
            If dct.Exists(arr1(row, clm)) Then
                row2 = dct(arr1(row, clm))
                If row2 <> 0 Then
                    If arrOut(row, 1) = 0 Then            'учитываем только первое совпадение
                        For clm2 = 1 To clCnt             'включение строки
                            arrOut(row, clm2) = arr3(row2, clm2)
                        Next
                    End If
                Else
                    Exit For                              'исключение строки
                End If
            End If
        Next
    Next
    
    Range("DM10:EA10").Resize(UBound(arr1)).Value = arrOut 'вывод результата
End Sub

Но он работает только с английскими словами. а с русскими нет. Помогите пожалуйста, чтобы макрос работал и с русскими словами.

@testuser2 · 08.06.2025, 02:42

carolina199x, с русскими словами все должно работать аналогично это юникод. Могу только предположить только, что может какая-то проблемма, связаная с буковй ё, в таком случае лучше везде заменить ее на е.

@carolina199x · 08.06.2025, 03:23 **[ТС]**

testuser2, нашла причину. просто слова все должны быть маленькими.

@testuser2 · 08.06.2025, 04:40

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

слова все должны быть маленькими

После Set dct = CreateObject("Scripting.Dictionary") нужно добавить

Visual Basic
1
dct.CompareMode = TextCompare

тогда не будет зависимости от регистра символов

Новые блоги и статьи Все статьи Все блоги /
Кредитный калькулятор Maks 05.08.2026 Решение задачи по прикладной информатике средствами 1С. Задача: Напишите приложение-калькулятор, которое помогает рассчитывать параметры кредита для аннуитетного и дифференцированного видов. . .	У нас сейчас поговорку "Опять 25" нужно переделать на "Опять +35". kumehtar 04.08.2026 С ностальгией вспоминаю времена моего детства, когда у нас и правда +25 - была максимальная температура летом. Раньше +25 °C реально казались вершиной жары, когда можно было весь день пропадать на. . .	Как ИИ начал спорить и врать (возможно почуяв опасность для себя от индустрии - уход от электроники). Hrethgir 04.08.2026 Недельный диалог, на фоне событий с НПЗ. Да, из спирта можно получать бензин, и это не сложно. Но потом в схеме я решил избавиться от насоса, при этом полностью сделав контроль подачи спирта в. . .	Термопринтер QR701 Argus19 03.08.2026 Термопринтер QR701 Купил два термопринтера QR701. На сэлф-тесте написано: Language: PC936 (GB18030). Что означает, что принтеры могут печатать только латиницу и китайские иероглифы. Так же. . .
Создание формы заимствованного документа Maks 03.08.2026 Задача: Необходимо создать собственную форму заимствованного документа. На форме должен быть реквизит "Покупатель", а также табличная часть со следующими реквизитами: - Расчетный счет покупателя. . .	Задача предоставления скидок покупателям Maks 03.08.2026 Задача: В документе "Продажи" необходимо реализовать функционал предоставления скидок покупателям. Скидка должна автоматически рассчитываться и подставляться в соответствующее поле при выборе. . .	Почему SEO не начинается с ключевых слов: что проверить до написания текстов Neotwalker 01.08.2026 Когда владельцу сайта предлагают заняться SEO, первым шагом часто становится сбор запросов и написание текстов. Логика кажется понятной: 1. Находим ключевые слова. 2. Добавляем их на. . .	Знание — сила: Доктрина интенциональности знаний, углубление в формулу Hrethgir 01.08.2026 https:/ / www. cyberforum. ru/ blog_attachment. php?attachmentid=11957&stc=1&d=1785567302 Знаменитый афоризм Фрэнсиса Бэкона «Знание — сила» (Scientia potentia est) в массовой культуре принято понимать. . .

@carolina199x 10 / 2 / 0 Регистрация: 21.04.2023 Сообщений: 130
	01.07.2024, 21:01 [ТС]
	АЕ, 0

@testuser2 1407 / 866 / 93 Регистрация: 08.02.2017 Сообщений: 3,699 Записей в блоге: 2
	08.06.2025, 02:42
	carolina199x, с русскими словами все должно работать аналогично это юникод. Могу только предположить только, что может какая-то проблемма, связаная с буковй ё, в таком случае лучше везде заменить ее на е. 0

@carolina199x 10 / 2 / 0 Регистрация: 21.04.2023 Сообщений: 130
	08.06.2025, 03:23 [ТС]
	testuser2, нашла причину. просто слова все должны быть маленькими. 0