Доброго всем дня - есть небольшая еселевская книга. В ней много страничек, но главные две: 2. Тексты ФРАЗЫ Требуется в [2. Тексты], по первой колонке - выделить цветом всю строку при нахождении определенного слова, из первой колонки по странице [ФРАЗЫ] Помогите придумать небольшой макрос. Спасибо.
Как и говорил - можно при помощи УФ. Хотя пример все равно так себе: всего одно слово - лень было еще набить для большей точности? Но дело Ваше. Вот такая формула в УФ:
выделяете всю таблицу на листе "Тексты", начиная с ячейки А2 -Главная -Условное форматирование. Форматировать на основании формулы. Вбиваете формулу выше. Важно: диапазон ФРАЗЫ!$A$2:$A$2 должен быть отсортирован по возрастанию и не должен содержать пустых ячеек.
Sub TT()
Dim wsIn As Worksheet, wsOut As Worksheet, I&, J&, objC As Range, objF As Range
Set wsIn = Worksheets("ФРАЗЫ"): Set wsOut = Worksheets("2. Тексты")
For Each objC In wsIn.UsedRange.Columns(1).Cells
Set objF = wsOut.UsedRange.Columns(1).Find(what:=objC, MatchCase:=False)
If Not objF Is Nothing Then
wsOut.Range(wsOut.Cells(objF.Row, 1), wsOut.Cells(objF.Row, wsOut.UsedRange.Columns.Count)).Interior.Color = vbYellow
End If
Next
End Sub
Пытливый, круто, но если я другие слова - кроме Москва пишу, то он больше ничего не берет и другие строки по данному сравнению первых столбцов в странице 2. Тексты не помечает((
Option Explicit
Sub Покрасить()
Dim dic As Object
Set dic = FillDic()
ColorRangeByDic Sheets("2. Тексты").Cells, dic
End Sub
Sub ColorRangeByDic(rn As Range, dic As Object)
rn.Interior.Pattern = xlNone
Dim r As Range
On Error Resume Next
Set r = Intersect(rn, rn.Parent.UsedRange)
On Error GoTo 0
If Not r Is Nothing Then
Dim rArea As Range
Dim y As Long
Dim x As Integer
Dim dy As Long
Dim dx As Integer
Dim vKey As Variant
For Each rArea In r.Areas
If rArea.Cells.Count = 1 Then
ReDim aArea(1 To 1, 1 To 1)
aArea(1, 1) = rArea
Else
aArea = rArea
End If
dy = rArea.Row - 1
dx = rArea.Column - 1
For y = 1 To UBound(aArea, 1)
For x = 1 To UBound(aArea, 2)
For Each vKey In dic.Keys
If InStr(LCase(aArea(y, x)), LCase(vKey)) > 0 Then
r.Parent.Cells(y + dy, x + dx).Interior.Color = RGB(255, 100, 100)
End If
Next
Next
Next
Next
End If
End Sub
Function FillDic() As Object
Dim y As Long
Dim arr As Variant
With Sheets("ФРАЗЫ")
y = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range(.Cells(1, 1), .Cells(y, 1 - (y = 1)))
End With
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
For y = 1 To UBound(arr, 1)
If arr(y, 1) <> "" Then
dic.Item(arr(y, 1)) = 0
End If
Next
Set FillDic = dic
End Function
Не могу понять что не так, пометка идет только один раз и все. Дальше если по столбцу появляются похожее слово в стр 2-Текст, оно больше не помечаеться. Прошу помощи у Фрумчан.
Эхе-хе...дурак я сегодня. Вот как надо было сразу:
Код
Sub TT()
Dim wsIn As Worksheet, wsOut As Worksheet, I&, J&, objC As Range, objF As Range, F$
Set wsIn = Worksheets("ФРАЗЫ"): Set wsOut = Worksheets("2. Тексты")
For Each objC In wsIn.UsedRange.Columns(1).Cells
Set objF = wsOut.UsedRange.Columns(1).Find(what:=objC, MatchCase:=False)
F$ = objF.Address
Do
If Not objF Is Nothing Then
wsOut.Range(wsOut.Cells(objF.Row, 1), wsOut.Cells(objF.Row, wsOut.UsedRange.Columns.Count)).Interior.Color = vbYellow
Set objF = wsOut.UsedRange.Columns(1).FindNext(objF)
End If
Loop While objF.Address <> F$
Next
End Sub
Не это я дурак!! - я не сказал что на странице ФРАЗЫ -в первой колонке - будет не одно слово - а список сверху вниз, пару сотен - и при нахождении таких слов в первой строке страницы 2-ТЕКСТ - он должен выделять цветом всю строку с таким текстом.
Сейчас да - если одно слово - все работает, но стоит в страницу ФРАЗЫ вписать больше одного в первом столбце - работать перестает((
Sub mrshkei()
Dim sh As Worksheet, sh2 As Worksheet, cell As Range
Dim i As Long, n As Long, lr As Long, lr2 As Long
Set sh = Worksheets("ФРАЗЫ"): Set sh2 = Worksheets("2. Тексты")
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
If sh.Cells(i, 1) <> Empty Then
For n = 1 To lr2
If sh2.Cells(n, 1) <> Empty Then
If InStr(1, sh2.Cells(n, 1), sh.Cells(i, 1), vbTextCompare) > 0 Then
If cell Is Nothing Then
Set cell = sh2.Range(sh2.Cells(n, 1), sh2.Cells(n, 8))
Else
Set cell = Union(cell, sh2.Range(sh2.Cells(n, 1), sh2.Cells(n, 8)))
End If
End If
End If
Next n
End If
Next i
If Not cell Is Nothing Then cell.Interior.ColorIndex = 3
End Sub
Михаил Иванченков, проверьте макрос из моего сообщения нумер 12. Он обрабатывает 1 й столбец заполненного диапазона с листа Фразы, каждую ячейку ищет на листе 2. Тексты и выделяет диапазон заполненных ячеек в строке с найденным значением. Выделяет несколько строк, если несколько раз найдет совпадение. В общем, вроде, как и хотели. Если что-то работает не так - покажите ЧТО. Работу макроса проверял на файле из сообщения #3.
Mershik написал: понял может быть не правильно, но вдруг
Все супер, только Ньюанс: https://skr.sh/sA6aDMUxNiD На вкладке фразы нет этих слов. Например: клининг химчистка штор. Видать есть город с вхождением букв таких. Типа Штормов А как то мона это убрать? чтобы точное соответствие?
Цитата
Пытливый написал: Если что-то работает не так - покажите ЧТО.
Михаил Иванченков, лучше покажите в файле кусок данных и код, который при запуске выдает указанную ошибку. Как ошибки выглядят я знаю, я не вижу, может данные относительно примера по другому расположены? Может при копировании макроса в рабочий файл допущен косяк? И, соответственно, не могу определить причину неправильного срабатывания, понимаете?
Данный код отлично работает. Но! - Если на втором листе данной книги, из 3го сообщения, Появляются еще фразы - то тогда скрипт сразу выдает такую ошибку: Object variable or With block variable not set Пример приложил.