Добрый день. Есть готовый макрос, который производит поиск и окрас определенного текста, который содержит ячейка. Значения берутся из ячеек, в коде их сцепляем с " тн." и с " %" и начинаем искать подкрашивая в зависимости от макс и мин значения, тем самым подсвечивая эти значения. Есть мелкий недочет: к примеру ищем "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.] На всякий случай Диапазон ячеек в котором ищем текст следующего состава значение тн. / значение % Поначалу ищем мин и макс " тн", затем также с " %"
Добрый день. Есть готовый макрос, который производит поиск и окрас определенного текста, который содержит ячейка. Значения берутся из ячеек, в коде их сцепляем с " тн." и с " %" и начинаем искать подкрашивая в зависимости от макс и мин значения, тем самым подсвечивая эти значения. Есть мелкий недочет: к примеру ищем "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
Слеш есть всегда, но как то на бумаге некрасиво, когда он или красный или зеленый. Решение вижу одно, это вторая макрос-раскраска для значений у который пробел спереди, то есть для % Решение номер два это новый макрос, который я не осилю ...
Слеш есть всегда, но как то на бумаге некрасиво, когда он или красный или зеленый. Решение вижу одно, это вторая макрос-раскраска для значений у который пробел спереди, то есть для % Решение номер два это новый макрос, который я не осилю ...antycapral
Pelena, Вот теперь вроде все ОК ! НО С меня конфеты ))))) Уже не первый раз выручаете ! Спасибо Вам ! [p.s.] Переношу во взрослый файл и новая беда, с другово ракурса, завтра поковыряю код еще раз, а то работу ни кто за меня не сделает )))
Pelena, Вот теперь вроде все ОК ! НО С меня конфеты ))))) Уже не первый раз выручаете ! Спасибо Вам ! [p.s.] Переношу во взрослый файл и новая беда, с другово ракурса, завтра поковыряю код еще раз, а то работу ни кто за меня не сделает )))antycapral
Сообщение отредактировал antycapral - Среда, 03.08.2016, 16:43
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
RAN, Доброго утра! Но при изменении значений не красит проценты, данные для раскраски могут в разных местах находиться. Вот пример, снизу работа вашего кода, сверху как надо:
RAN, Доброго утра! Но при изменении значений не красит проценты, данные для раскраски могут в разных местах находиться. Вот пример, снизу работа вашего кода, сверху как надо: antycapral
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
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