Страницы: 1
RSS
Пометить строку по заданному условию
 
Доброго всем дня - есть небольшая еселевская книга. В ней много страничек, но главные две:
2. Тексты
ФРАЗЫ
Требуется в [2. Тексты], по первой колонке - выделить цветом всю строку при нахождении определенного слова, из первой колонки по странице [ФРАЗЫ]
Помогите придумать небольшой макрос. Спасибо.

пример удален. См. ниже
Изменено: vikttur - 16.09.2021 11:18:39
 
Цитата
Михаил Иванченков написал:
придумать небольшой макрос
а почему именно макрос? Возможно, это решается при помощи условного форматирования. НО
Цитата
Михаил Иванченков написал:
из первой колонки по странице [ФРАЗЫ]
в листе ФРАЗЫ нет ни одной заполненной строки. Поэтому вообще непонятно что и как надо сравнивать и искать.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Сорян, завтыкал - добавил
Изменено: vikttur - 16.09.2021 11:18:59
 
Как и говорил - можно при помощи УФ. Хотя пример все равно так себе: всего одно слово - лень было еще набить для большей точности? :)
Но дело Ваше. Вот такая формула в УФ:
Код
=НЕ(ЕОШИБКА(ПРОСМОТР(2;1/ПОИСК(ФРАЗЫ!$A$2:$A$2;A2);ФРАЗЫ!$A$2:$A$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
Изменено: Пытливый - 16.09.2021 12:44:57
Кому решение нужно - тот пример и рисует.
 
Пытливый, круто, но если я другие слова - кроме Москва пишу, то он больше ничего не берет и другие строки по данному сравнению первых столбцов в странице 2. Тексты не помечает((
Изменено: vikttur - 16.09.2021 11:56:54
 
без макроса
Код
=ЕСЛИ(ЕПУСТО(RC1);;СУММ(СЧЁТЕСЛИ(RC1;Фразы)))
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ещё вариант макросом.
Код
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
 
Михаил Иванченков, покажите, что и где вы пишете. Я же не вижу - как понять почему не работает? Да никак. :)

З.Ы. Точно. Был косяк. Исправил в своем прошлом сообщении.
Изменено: Пытливый - 16.09.2021 12:45:26
Кому решение нужно - тот пример и рисует.
 
Не могу понять что не так, пометка идет только один раз и все. Дальше если по столбцу появляются похожее слово в стр 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
Кому решение нужно - тот пример и рисует.
 
https://skr.sh/sA4peex7gBi - не пускает((
Изменено: vikttur - 16.09.2021 20:48:12
 
Не это я дурак!! - я не сказал что на странице ФРАЗЫ  -в первой колонке - будет не одно слово - а список сверху вниз, пару сотен - и при нахождении таких слов в первой строке страницы 2-ТЕКСТ - он должен выделять цветом всю строку с таким текстом.

Сейчас да - если одно слово - все работает, но стоит в страницу ФРАЗЫ вписать больше одного в первом столбце - работать перестает((

Очень прошу подсобить, спасибо.
Изменено: Михаил Иванченков - 20.09.2021 23:11:55
 
Михаил Иванченков, понял может быть не правильно, но вдруг
Код
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

Изменено: Mershik - 17.09.2021 09:27:14
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Михаил Иванченков написал:
на странице ФРАЗЫ  -в первой колонке - будет не одно слово - а список сверху вниз
См. #8.
 
Михаил Иванченков, проверьте макрос из моего сообщения нумер 12.
Он обрабатывает 1 й столбец заполненного диапазона с листа Фразы, каждую ячейку ищет на листе 2. Тексты и выделяет диапазон заполненных ячеек в строке с найденным значением. Выделяет несколько строк, если несколько раз найдет совпадение. В общем, вроде, как и хотели.
Если что-то работает не так - покажите ЧТО.
Работу макроса проверял на файле из сообщения #3.
Изменено: Пытливый - 17.09.2021 12:12:16
Кому решение нужно - тот пример и рисует.
 
Цитата
Mershik написал: понял может быть не правильно, но вдруг
Все супер, только Ньюанс: https://skr.sh/sA6aDMUxNiD
На вкладке фразы нет этих слов. Например: клининг химчистка штор. Видать есть город с вхождением букв таких. Типа Штормов
А как то мона это убрать? чтобы точное соответствие?

Цитата
Пытливый написал: Если что-то работает не так - покажите ЧТО.
https://skr.sh/sA6yAVoCvN9 - вот так пишет при запуске. Могу видос снять показать.
Изменено: vikttur - 21.09.2021 00:44:40
 
Цитата
Михаил Иванченков написал:
я не сказал что на странице ФРАЗЫ  -в первой колонке - будет не одно слово - а список
см. файл из сообщения 7
дополняйте спиоок фраз, смотрите как это повлияло на количество отмеченных строк на первом листе)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко написал: файл из сообщения 7
Да, но если туда вставлять новые фразы на стр 2-ТЕКСТ, то все ломается
Изменено: vikttur - 21.09.2021 00:43:53
 
Михаил Иванченков, лучше покажите в файле кусок данных и код, который при запуске выдает указанную ошибку. Как ошибки выглядят я знаю, я не вижу, может данные относительно примера по другому расположены? Может при копировании макроса в рабочий файл допущен косяк?
И, соответственно, не могу определить причину неправильного срабатывания, понимаете?
Кому решение нужно - тот пример и рисует.
 
Данный код отлично работает. Но! - Если на втором листе данной книги, из 3го сообщения, Появляются еще фразы - то тогда скрипт сразу выдает такую ошибку: Object variable or With block variable not set  Пример приложил.
Изменено: Михаил Иванченков - 20.09.2021 23:10:30
 
добавил на лист Фразы слово цена
на листе 2.Тексты зарисовалась строка 4
что не так?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Вооооот! Теперь понятно, где косяк. Добавил еще одну проверку на наличие значений из ФРАЗЫ в 2.Тексты.

Макрос в модуле в прилагаемом файле.
Кому решение нужно - тот пример и рисует.
Страницы: 1
Наверх