Добрый день. Прошу вашей помощи. Есть таблицы, которых много. Хотелось бы подсвечивать ячейки которые выходят за границы допусков. Вариант создавать условное форматирование занимает много времени, и бывают моменты когда границы допусков меняются. Все таблицы всегда имеют один формат.
Добрый день. Прошу вашей помощи. Есть таблицы, которых много. Хотелось бы подсвечивать ячейки которые выходят за границы допусков. Вариант создавать условное форматирование занимает много времени, и бывают моменты когда границы допусков меняются. Все таблицы всегда имеют один формат.Sasha318
в первой строке задаете параметры, затем кликаете покрасить или очистить. в модуль листа код
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$K$1:$L$1" Then PaintCell If Target.Address = "$M$1:$N$1" Then ClearCell End Sub
Sub PaintCell() runer Me.Range("C1").Value, Me.Range("D1").Value, Me.Range("E1").Interior.color, Me.Range("J1").Value End Sub
Sub ClearCell() runer Me.Range("C1").Value, Me.Range("D1").Value, 0, Me.Range("J1").Value End Sub Sub runer(min, max, color, rang) If color = 0 Then Me.Range(rang).Interior.color = 16777215: Exit Sub For Each cl In Me.Range(rang) If cl.Value < min Or cl.Value > max Then cl.Interior.color = color Next cl End Sub
в первой строке задаете параметры, затем кликаете покрасить или очистить. в модуль листа код
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Address = "$K$1:$L$1" Then PaintCell If Target.Address = "$M$1:$N$1" Then ClearCell End Sub
Sub PaintCell() runer Me.Range("C1").Value, Me.Range("D1").Value, Me.Range("E1").Interior.color, Me.Range("J1").Value End Sub
Sub ClearCell() runer Me.Range("C1").Value, Me.Range("D1").Value, 0, Me.Range("J1").Value End Sub Sub runer(min, max, color, rang) If color = 0 Then Me.Range(rang).Interior.color = 16777215: Exit Sub For Each cl In Me.Range(rang) If cl.Value < min Or cl.Value > max Then cl.Interior.color = color Next cl End Sub
For Each r In Range("B1", Cells(Rows.Count, 2).End(xlUp)).Cells If r.Value = "TOLERANCE" Then For j = 2 To 21 If Len(r(0, j)) Then For i = 2 To 4 If r(i, j) > r(0, j) Or r(i, j) < r(1, j) Then r(i, j).Interior.Color = vbYellow Else r(i, j).Interior.Color = xlNone End If Next i End If Next j End If Next r End Sub
[/vba]
Sasha318, привет а если так: [vba]
Код
Sub ertert() Dim r As Range, i&, j&
For Each r In Range("B1", Cells(Rows.Count, 2).End(xlUp)).Cells If r.Value = "TOLERANCE" Then For j = 2 To 21 If Len(r(0, j)) Then For i = 2 To 4 If r(i, j) > r(0, j) Or r(i, j) < r(1, j) Then r(i, j).Interior.Color = vbYellow Else r(i, j).Interior.Color = xlNone End If Next i End If Next j End If Next r End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
