Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Поиск и окрас текста в ячейке, подредакировать макрос - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поиск и окрас текста в ячейке, подредакировать макрос (Макросы/Sub)
Поиск и окрас текста в ячейке, подредакировать макрос
antycapral Дата: Среда, 03.08.2016, 10:52 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 52
Репутация: 5 ±
Замечаний: 0% ±

Excel 2016
Добрый день.
Есть готовый макрос, который производит поиск и окрас определенного текста, который содержит ячейка.
Значения берутся из ячеек, в коде их сцепляем с " тн." и с " %" и начинаем искать подкрашивая в зависимости от макс и мин значения, тем самым подсвечивая эти значения.
Есть мелкий недочет: к примеру ищем "4 %" , он его находит, красит, но также красит десятые в значениях 8,4 % , 12,4 % и так далее где оно встречается. Смотреть картинку

Вот сам код:
[vba]
Код

Sub процедура_раскраски_текста(res, ra As Range, Цвет)
Dim cell As Range
Dim txt$
Dim v, pos&
    On Error Resume Next: Err.Clear
'           процедура раскраски текста
           txt$ = Trim(res)
'            txt$ = res

            For Each cell In ra.Cells    ' перебираем все ячейки
                pos = 1
                If cell.Text Like "*" & txt & "*" Then
                    arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
                    If UBound(arr) > 0 Then    ' если подстрока найдена
                        For Each v In arr    ' перебираем все вхождения
                            pos = pos + Len(v)    ' начальная позиция
                            With cell.Characters(pos, Len(txt))
                    .Font.Color = Цвет    ' выделяем цветом
                            End With
                            pos = pos + Len(txt)
                        Next v
                    End If
                End If
            Next cell
End Sub

[/vba]
Пробовал добавлять в переменную для поиска пробел в начале, не помогло, чтобы искал " 4 %"
[vba]
Код
txt$ = Trim(res)  'отсекает все пробелы, а без нее неработает ((
[/vba]
[p.s.]
На всякий случай
Диапазон ячеек в котором ищем текст следующего состава
значение тн. / значение %
Поначалу ищем мин и макс " тн", затем также с " %"
К сообщению приложен файл: 3957361.png(66Kb) · __.xlsm(21Kb)


Сообщение отредактировал antycapral - Среда, 03.08.2016, 10:57
 
Ответить
СообщениеДобрый день.
Есть готовый макрос, который производит поиск и окрас определенного текста, который содержит ячейка.
Значения берутся из ячеек, в коде их сцепляем с " тн." и с " %" и начинаем искать подкрашивая в зависимости от макс и мин значения, тем самым подсвечивая эти значения.
Есть мелкий недочет: к примеру ищем "4 %" , он его находит, красит, но также красит десятые в значениях 8,4 % , 12,4 % и так далее где оно встречается. Смотреть картинку

Вот сам код:
[vba]
Код

Sub процедура_раскраски_текста(res, ra As Range, Цвет)
Dim cell As Range
Dim txt$
Dim v, pos&
    On Error Resume Next: Err.Clear
'           процедура раскраски текста
           txt$ = Trim(res)
'            txt$ = res

            For Each cell In ra.Cells    ' перебираем все ячейки
                pos = 1
                If cell.Text Like "*" & txt & "*" Then
                    arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
                    If UBound(arr) > 0 Then    ' если подстрока найдена
                        For Each v In arr    ' перебираем все вхождения
                            pos = pos + Len(v)    ' начальная позиция
                            With cell.Characters(pos, Len(txt))
                    .Font.Color = Цвет    ' выделяем цветом
                            End With
                            pos = pos + Len(txt)
                        Next v
                    End If
                End If
            Next cell
End Sub

[/vba]
Пробовал добавлять в переменную для поиска пробел в начале, не помогло, чтобы искал " 4 %"
[vba]
Код
txt$ = Trim(res)  'отсекает все пробелы, а без нее неработает ((
[/vba]
[p.s.]
На всякий случай
Диапазон ячеек в котором ищем текст следующего состава
значение тн. / значение %
Поначалу ищем мин и макс " тн", затем также с " %"

Автор - antycapral
Дата добавления - 03.08.2016 в 10:52
sboy Дата: Среда, 03.08.2016, 11:11 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 198
Репутация: 49 ±
Замечаний: 0% ±

Excel 2007
Пробовал добавлять в переменную для поиска пробел в начале, не помогло, чтобы искал " 4 %"

добавьте пробел в эту строку
[vba]
Код
If cell.Text Like "*" & " " & txt & "*" Then
[/vba]
 
Ответить
Сообщение
Пробовал добавлять в переменную для поиска пробел в начале, не помогло, чтобы искал " 4 %"

добавьте пробел в эту строку
[vba]
Код
If cell.Text Like "*" & " " & txt & "*" Then
[/vba]

Автор - sboy
Дата добавления - 03.08.2016 в 11:11
antycapral Дата: Среда, 03.08.2016, 11:16 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 52
Репутация: 5 ±
Замечаний: 0% ±

Excel 2016
sboy, Спасибо, все как доктор прописал! +1 в репу
 
Ответить
Сообщениеsboy, Спасибо, все как доктор прописал! +1 в репу

Автор - antycapral
Дата добавления - 03.08.2016 в 11:16
Pelena Дата: Среда, 03.08.2016, 11:18 | Сообщение № 4
Группа: Модераторы
Ранг: Экселист
Сообщений: 9869
Репутация: 2263 ±
Замечаний: 0% ±

Excel 2010 & Mac Excel 2011
Можно слэш задействовать
К сообщению приложен файл: 5116859.xlsm(21Kb)


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеМожно слэш задействовать

Автор - Pelena
Дата добавления - 03.08.2016 в 11:18
antycapral Дата: Среда, 03.08.2016, 14:55 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 52
Репутация: 5 ±
Замечаний: 0% ±

Excel 2016
Как всегда поспешил, проценты красит как надо, а вот тонны пропускает, так как они начинаются без пробела спереди....

добавьте пробел в эту строку
If cell.Text Like "*" & " " & txt & "*" Then

Не красит тонны.... Печалька

Елена, а как можно без слеша ? Я знаю что можно )))
 
Ответить
СообщениеКак всегда поспешил, проценты красит как надо, а вот тонны пропускает, так как они начинаются без пробела спереди....

добавьте пробел в эту строку
If cell.Text Like "*" & " " & txt & "*" Then

Не красит тонны.... Печалька

Елена, а как можно без слеша ? Я знаю что можно )))

Автор - antycapral
Дата добавления - 03.08.2016 в 14:55
Pelena Дата: Среда, 03.08.2016, 15:01 | Сообщение № 6
Группа: Модераторы
Ранг: Экселист
Сообщений: 9869
Репутация: 2263 ±
Замечаний: 0% ±

Excel 2010 & Mac Excel 2011
А что, слэш не всегда присутствует? Я к тому, почему без слэша?


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеА что, слэш не всегда присутствует? Я к тому, почему без слэша?

Автор - Pelena
Дата добавления - 03.08.2016 в 15:01
antycapral Дата: Среда, 03.08.2016, 15:15 | Сообщение № 7
Группа: Пользователи
Ранг: Участник
Сообщений: 52
Репутация: 5 ±
Замечаний: 0% ±

Excel 2016
Слеш есть всегда, но как то на бумаге некрасиво, когда он или красный или зеленый.
Решение вижу одно, это вторая макрос-раскраска для значений у который пробел спереди, то есть для %
Решение номер два это новый макрос, который я не осилю ...
 
Ответить
СообщениеСлеш есть всегда, но как то на бумаге некрасиво, когда он или красный или зеленый.
Решение вижу одно, это вторая макрос-раскраска для значений у который пробел спереди, то есть для %
Решение номер два это новый макрос, который я не осилю ...

Автор - antycapral
Дата добавления - 03.08.2016 в 15:15
Pelena Дата: Среда, 03.08.2016, 15:35 | Сообщение № 8
Группа: Модераторы
Ранг: Экселист
Сообщений: 9869
Репутация: 2263 ±
Замечаний: 0% ±

Excel 2010 & Mac Excel 2011
Так проверьте. Вроде правильно срабатывает и при варианте, например, 122 т и минимальном 22 т
К сообщению приложен файл: 4341866.xlsm(21Kb)


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеТак проверьте. Вроде правильно срабатывает и при варианте, например, 122 т и минимальном 22 т

Автор - Pelena
Дата добавления - 03.08.2016 в 15:35
antycapral Дата: Среда, 03.08.2016, 16:30 | Сообщение № 9
Группа: Пользователи
Ранг: Участник
Сообщений: 52
Репутация: 5 ±
Замечаний: 0% ±

Excel 2016
Pelena, Вот теперь вроде все ОК !
НО С меня конфеты ))))) Уже не первый раз выручаете ! Спасибо Вам !
[p.s.]
Переношу во взрослый файл и новая беда, с другово ракурса, завтра поковыряю код еще раз, а то работу ни кто за меня не сделает )))


Сообщение отредактировал antycapral - Среда, 03.08.2016, 16:43
 
Ответить
СообщениеPelena, Вот теперь вроде все ОК !
НО С меня конфеты ))))) Уже не первый раз выручаете ! Спасибо Вам !
[p.s.]
Переношу во взрослый файл и новая беда, с другово ракурса, завтра поковыряю код еще раз, а то работу ни кто за меня не сделает )))

Автор - antycapral
Дата добавления - 03.08.2016 в 16:30
RAN Дата: Среда, 03.08.2016, 19:05 | Сообщение № 10
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4277
Репутация: 829 ±
Замечаний: 0% ±

2010
[vba]
Код
Sub Мяу()
    Dim a, aa
    For i = 15 To 22
        a = Application.Search(Range("P31").Value, Split(Cells(36, i).Value)(0))
        If Not IsError(a) Then
            aa = Application.Search("/", Cells(36, i))
            Cells(36, i).Font.Color = vbGreen
            Cells(36, i).Characters(aa, 1).Font.ColorIndex = xlAutomatic
            Exit For
        End If
    Next
    For i = 15 To 22
        a = Application.Search(Range("P33").Value, Split(Cells(36, i).Value)(0))
        If Not IsError(a) Then
            aa = Application.Search("/", Cells(36, i))
            Cells(36, i).Font.Color = vbRed
            Cells(36, i).Characters(aa, 1).Font.ColorIndex = xlAutomatic
            Exit For
        End If
    Next
End Sub
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение[vba]
Код
Sub Мяу()
    Dim a, aa
    For i = 15 To 22
        a = Application.Search(Range("P31").Value, Split(Cells(36, i).Value)(0))
        If Not IsError(a) Then
            aa = Application.Search("/", Cells(36, i))
            Cells(36, i).Font.Color = vbGreen
            Cells(36, i).Characters(aa, 1).Font.ColorIndex = xlAutomatic
            Exit For
        End If
    Next
    For i = 15 To 22
        a = Application.Search(Range("P33").Value, Split(Cells(36, i).Value)(0))
        If Not IsError(a) Then
            aa = Application.Search("/", Cells(36, i))
            Cells(36, i).Font.Color = vbRed
            Cells(36, i).Characters(aa, 1).Font.ColorIndex = xlAutomatic
            Exit For
        End If
    Next
End Sub
[/vba]

Автор - RAN
Дата добавления - 03.08.2016 в 19:05
antycapral Дата: Четверг, 04.08.2016, 09:09 | Сообщение № 11
Группа: Пользователи
Ранг: Участник
Сообщений: 52
Репутация: 5 ±
Замечаний: 0% ±

Excel 2016
RAN, Доброго утра!
Но при изменении значений не красит проценты, данные для раскраски могут в разных местах находиться.
Вот пример, снизу работа вашего кода, сверху как надо:
К сообщению приложен файл: 2199385.png(58Kb)


Сообщение отредактировал antycapral - Четверг, 04.08.2016, 09:10
 
Ответить
СообщениеRAN, Доброго утра!
Но при изменении значений не красит проценты, данные для раскраски могут в разных местах находиться.
Вот пример, снизу работа вашего кода, сверху как надо:

Автор - antycapral
Дата добавления - 04.08.2016 в 09:09
RAN Дата: Четверг, 04.08.2016, 10:13 | Сообщение № 12
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4277
Репутация: 829 ±
Замечаний: 0% ±

2010
[vba]
Код
Sub Мяв()
    Dim aa&, spl, i&
    For i = 15 To 22
        aa = Application.Search("/", Cells(36, i))
        spl = Split(Cells(36, i).Value, "/")
        If Val(spl(0)) = Range("P31") Then
            Cells(36, i).Characters(1, aa - 1).Font.Color = vbGreen
        ElseIf Val(spl(0)) = Range("P33") Then
            Cells(36, i).Characters(1, aa - 1).Font.Color = vbRed
        ElseIf Val(Replace(Replace(spl(1), ",", "."), "%", "")) = Range("Q31") Then
            Cells(36, i).Characters(aa + 1, Len(Cells(36, i)) - aa).Font.Color = vbGreen
        ElseIf Val(Replace(Replace(spl(1), ",", "."), "%", "")) = Range("Q33") Then
            Cells(36, i).Characters(aa + 1, Len(Cells(36, i)) - aa).Font.Color = vbRed
        End If
    Next
End Sub
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение[vba]
Код
Sub Мяв()
    Dim aa&, spl, i&
    For i = 15 To 22
        aa = Application.Search("/", Cells(36, i))
        spl = Split(Cells(36, i).Value, "/")
        If Val(spl(0)) = Range("P31") Then
            Cells(36, i).Characters(1, aa - 1).Font.Color = vbGreen
        ElseIf Val(spl(0)) = Range("P33") Then
            Cells(36, i).Characters(1, aa - 1).Font.Color = vbRed
        ElseIf Val(Replace(Replace(spl(1), ",", "."), "%", "")) = Range("Q31") Then
            Cells(36, i).Characters(aa + 1, Len(Cells(36, i)) - aa).Font.Color = vbGreen
        ElseIf Val(Replace(Replace(spl(1), ",", "."), "%", "")) = Range("Q33") Then
            Cells(36, i).Characters(aa + 1, Len(Cells(36, i)) - aa).Font.Color = vbRed
        End If
    Next
End Sub
[/vba]

Автор - RAN
Дата добавления - 04.08.2016 в 10:13
antycapral Дата: Четверг, 04.08.2016, 13:30 | Сообщение № 13
Группа: Пользователи
Ранг: Участник
Сообщений: 52
Репутация: 5 ±
Замечаний: 0% ±

Excel 2016
[vba]
Код

Sub Мяв()
    Dim aa&, spl, i&
    For i = 15 To 22
        aa = Application.Search("/", Cells(36, i))
        spl = Split(Cells(36, i).Value, "/")
        If Val(spl(0)) = Range("P31") Then
            Cells(36, i).Characters(1, aa - 1).Font.Color = vbGreen
        ElseIf Val(spl(0)) = Range("P33") Then
            Cells(36, i).Characters(1, aa - 1).Font.Color = vbRed
        End If
' иначе проценты пропускеат если они в одной ячейке
        If Val(Replace(Replace(spl(1), ",", "."), "%", "")) = Range("Q31") Then
            Cells(36, i).Characters(aa + 1, Len(Cells(36, i)) - aa).Font.Color = vbGreen
        ElseIf Val(Replace(Replace(spl(1), ",", "."), "%", "")) = Range("Q33") Then
            Cells(36, i).Characters(aa + 1, Len(Cells(36, i)) - aa).Font.Color = vbRed
        End If
    Next
End Sub

[/vba]
Вот так правильно все делает! Спасибо Котяра ))
 
Ответить
Сообщение[vba]
Код

Sub Мяв()
    Dim aa&, spl, i&
    For i = 15 To 22
        aa = Application.Search("/", Cells(36, i))
        spl = Split(Cells(36, i).Value, "/")
        If Val(spl(0)) = Range("P31") Then
            Cells(36, i).Characters(1, aa - 1).Font.Color = vbGreen
        ElseIf Val(spl(0)) = Range("P33") Then
            Cells(36, i).Characters(1, aa - 1).Font.Color = vbRed
        End If
' иначе проценты пропускеат если они в одной ячейке
        If Val(Replace(Replace(spl(1), ",", "."), "%", "")) = Range("Q31") Then
            Cells(36, i).Characters(aa + 1, Len(Cells(36, i)) - aa).Font.Color = vbGreen
        ElseIf Val(Replace(Replace(spl(1), ",", "."), "%", "")) = Range("Q33") Then
            Cells(36, i).Characters(aa + 1, Len(Cells(36, i)) - aa).Font.Color = vbRed
        End If
    Next
End Sub

[/vba]
Вот так правильно все делает! Спасибо Котяра ))

Автор - antycapral
Дата добавления - 04.08.2016 в 13:30
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поиск и окрас текста в ячейке, подредакировать макрос (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!