Здравствуйте, уважаемые форумчане. Помогите, пожалуйста, решить такую задачу.
Есть файл, в файле 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
Спасибо большое! Попробую. Пробелы не нужны.
Уважаемый, Администратор. Макрос работает. Спасибо большое вам! Но у меня тут одна проблемка. Дело в том, что я задание немного упростила, чтобы было легче понимать. Я написала что мне надо узнать содержит ли название продукции название линии продаж (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
Спасибо!