Excel VBA: Содержит ли ячейка слова из других ячеек

[Viktoria2291]

Здравствуйте, уважаемые форумчане. Помогите, пожалуйста, решить такую задачу.
Есть файл, в файле 2 столбца: В и С. Оба столбца содержат текстовую информацию. В ячейках столбца В содержатся полные названия продукции, состоящие из нескольких слов. В ячейках столбца С содержатся названия линий продаж. Мое задание: определить содержит ли каждое название продукции название линии продаж. Соответственно, мне нужно каждую ячейку столбца B сравнить во всем столбцом C, если хоть одно слово совпадает, то в столбце Е написать "правда", ну или как-то по-другому отметить.
Файлик с примером прикрепила.
Я пробовала разные функции, но ничего не получается, макрос тоже не получается..
Была бы вам очень благодарна за помощь, очень нужно!

[вложение удалено администратором]

[Администратор]

В столбце C у вас есть концевые пробелы - нужно их удалить. Если пробелы нужны, то тогда потребуется внести изменения в макрос.

Макрос

Sub Main()
       
    Dim shAct As Worksheet, arrB(), arrC(), arrE(), lr As Long, i As Long, j As Long
   
   
    '1. Отключение монитора (для усокорения макроса).
    Application.ScreenUpdating = False
   
    '2. Vba-именование активного листа (лучше явно работать с нужным листом).
    Set shAct = ActiveSheet
   
    '3. Очистка столбца E от старых данных.
    lr = shAct.Columns("E").Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    If lr > 3 Then
        shAct.Range("E4:E" & lr).Value = ""
    End If
   
    '4. Копирование столбца B в vba-массив (для ускорения кода).
    lr = shAct.Columns("B").Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    arrB() = shAct.Range("B4:B" & lr).Value
   
    '5. Копирование столбца C в vba-массив (для ускорения кода).
    lr = shAct.Columns("C").Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    arrC() = shAct.Range("C4:C" & lr).Value
   
    '6. Создание ячеек в массиве-результате (сначала в него запишутся True и False).
    ReDim arrE(1 To UBound(arrB, 1), 1 To 1)
   
    '7. Функционал.
    For i = 1 To UBound(arrB, 1) Step 1
        For j = 1 To UBound(arrC, 1) Step 1
            ' vbTextCompare - поиск без учёта регистра (больших/маленьких букв).
            If InStr(1, arrB(i, 1), arrC(j, 1), vbTextCompare) > 0 Then
                arrE(i, 1) = True
                Exit For
            End If
        Next j
        ' Запись False.
        If arrE(i, 1) = Empty Then
            arrE(i, 1) = False
        End If
    Next i
   
    '8. Вставка результата в эксель.
    shAct.Range("E4").Resize(UBound(arrE, 1)).Value = arrE()
   
    '9. Включение монитора.
    Application.ScreenUpdating = True
   
    '10. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

[свернуть]

[Viktoria2291]

Спасибо большое! Попробую. Пробелы не нужны.

[Viktoria2291]

Уважаемый, Администратор. Макрос работает. Спасибо большое вам! Но у меня тут одна проблемка. Дело в том, что я задание немного упростила, чтобы было легче понимать. Я написала что мне надо узнать содержит ли название продукции название линии продаж (sales line), но вообще мне надо найти еще содержит ли другие названия (название материала и т.п., всего 9 разных названий). Т.е. по факту мне нужно сделать одну и ту же операцию 9 раз (сравнить каждую ячейку со столбцом и если хоть одно слово совпадает - написать "правда").
Я думала, что я просто ваш макрос просто вставлю несколько раз (заменив названия столбцов), но так не получается. Первое сравнение работает корректно, а остальные 8 - нет. Я пыталась его изменить немного, но все  равно не работает и прямо стыдно результат сбрасывать(
Вы не подскажите, как решить эту проблему? Прикрепила сейчас полный файл (прошу прощения, там названия столбцов не те).
Я очень извиняюсь за путаницу, правда хотела как лучше (упростить), а получилось что не могу сама элементарно доделать. Вы меня очень выручите, если подскажите. Спасибо!

[вложение удалено администратором]

[Администратор]

Макрос. Версия от 06.01.2016 9:37

Sub Main()
       
    Dim shAct As Worksheet, arrF(), arrPhrases(), arrRes(), lr As Long, i As Long, j As Long, c As Long
   
   
    '1. Vba-именование активного листа (лучше явно работать с нужным листом).
    Set shAct = ActiveSheet
   
    '2. Отключение монитора (для ускорения макроса).
    Application.ScreenUpdating = False
   
    '3. Очистка столбцов-результатов от старых данных.
    For c = 9 To 25 Step 2
        lr = shAct.Columns(c).Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
        If lr > 1 Then
            shAct.Cells(2, c).Resize(lr - 1).Value = ""
        End If
    Next c
   
    '4. Копирование столбца F (Name) в vba-массив (для ускорения кода).
    lr = shAct.Columns("F").Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
    If lr = 2 Then
        ReDim arrF(1 To 1, 1 To 1)
        arrF(1, 1) = shAct.Range("F2").Value
    Else
        arrF() = shAct.Range("F2:F" & lr).Value
    End If
   
    '5. Создание ячеек в массиве-результате (сначала в него будут записываться True и False).
    ReDim arrRes(1 To UBound(arrF, 1), 1 To 1)

    '6. Функционал.
    For c = 8 To 24 Step 2
       
        '1) Копирование столбца с фразами в vba-массив (для ускорения кода).
        lr = shAct.Columns(c).Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False).Row
        ' Если в столбце нет фраз (не знаю, возможно ли такое).
        If lr < 2 Then
            GoTo metka
        End If
        If lr = 2 Then
            ReDim arrPhrases(1 To 1, 1 To 1)
            arrPhrases(1, 1) = shAct.Cells(2, c).Value
        Else
            arrPhrases() = shAct.Cells(2, c).Resize(lr - 1).Value
        End If
       
        '2) Поиск.
        For i = 1 To UBound(arrF, 1) Step 1
            ' Сборос ячейки в массиве-результате от прежнего использования.
                ' Если не будет найдено, то так и останется False.
            arrRes(i, 1) = False
            For j = 1 To UBound(arrPhrases, 1) Step 1
                ' vbTextCompare - поиск без учёта регистра (больших/маленьких букв).
                If InStr(1, arrF(i, 1), arrPhrases(j, 1), vbTextCompare) > 0 Then
                    arrRes(i, 1) = True
                    Exit For
                End If
            Next j
        Next i
       
        '3) Вставка результата в эксель.
        shAct.Cells(2, c + 1).Resize(UBound(arrRes, 1)).Value = arrRes()
       
metka:
    Next c

    '7. Включение монитора.
    Application.ScreenUpdating = True
   
    '8. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

[свернуть]

[Viktoria2291]

Спасибо!