Цвет ячейки, если введено определенное число

Question

Мне нужно запрограммировать условный формат в Excel 2016 без использования существующего инструмента условного форматирования.

Я хочу написать это, например, в частной подпрограмме:

для диапазона A1: A100:
- Если значение> = 1, то цвет = зеленый
- Если значение <1 или "", то красный цвет </p>

для диапазона B1: B100
- Если значение> = 3затем цвет = зеленый
- если значение равно <3 &> 0, то цвет желтый
- если значение равно 0 или "" цвет красный

Мой код.Когда я сохраняю его, во втором заданном диапазоне ничего не происходит, даже после повторного открытия книги Excel:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngObserve As Range, rngCell As Range

Set rngObserve = Intersect(Target, Range("A1:A100"))

If rngObserve Is Nothing Then
    Exit Sub
End If

For Each rngCell In rngObserve.Cells
    If Not Intersect(rngCell, rngObserve) Is Nothing Then

        If rngCell.Value = vbNullString Then
            rngCell.Interior.Color = xlNone

        ElseIf rngCell.Value < 1 Then
            rngCell.Interior.ColorIndex = 3 'red

        ElseIf rngCell.Value >= 1 Then
            rngCell.Interior.ColorIndex = 4 'green

        Else
            rngCell.Interior.ColorIndex = 3
        End If
    End If
Next

Set rngObserve = Intersect(Target, Range("B1:B100"))

If rngObserve Is Nothing Then
    Exit Sub
End If

For Each rngCell In rngObserve.Cells

    If Not Intersect(rngCell, rngObserve) Is Nothing Then

        If rngCell.Value = vbNullString Then
            rngCell.Interior.Color = xlNone

        ElseIf rngCell.Value < 1& > 0 Then
            rngCell.Interior.ColorIndex = 6 'yellow

        ElseIf rngCell.Value >= 3 Then
            rngCell.Interior.ColorIndex = 4 'green

        Else
            rngCell.Interior.ColorIndex = 3

        End If
    End If
Next

End Sub

Answer 1

Вам нужно Range("A:A"), но было бы лучше, если бы оно было сокращено до ячеек в свойстве UsedRange рабочего листа.Кроме того, значение пустой ячейки считается нулевым, поэтому сначала следует проверить условие.

dim MyPlage As Range, cell as range

Set MyPlage = intersect(activesheet.Range("A:A"), activesheet.UsedRange)

For Each Cell In MyPlage

    If isempty(cell) then
        Cell.Interior.ColorIndex = 3 'red
    elseIf Cell.Value < 1 Then
        Cell.Interior.ColorIndex = 3 'red
    ElseIf Cell.Value >= 1 Then
        Cell.Interior.ColorIndex = 4 'green
    end if

Next cell

Я отделил пустые ячейки и ячейки значением меньше единицы, потому что они предназначены для всех намерений иДля того же, в будущем вы можете выбрать другой цвет для одного из них.

Возможно, будет проще установить все в vbRed, а затем выборочно установить значения, большие или равные 1, как vbGreeen.

dim MyPlage As Range, cell as range

Set MyPlage = intersect(activesheet.Range("A:A"), activesheet.UsedRange)

MyPlage.Interior.ColorIndex = 3 'red 

For Each Cell In MyPlage

    If  Cell.Value >= 1 Then
        Cell.Interior.ColorIndex = 4 'green
    end if

Next cell

Answer 2

1. Вы должны использовать событие Worksheet_Change.Вы не можете переименовать это событие!
2. Используйте Intersect(Target, Target.Parent.Range("A:A")), чтобы получить только ячейки в столбце A.
3. Проверьте значение каждой ячейки в Target, если это число If IsNumeric(Cell.Value) Then, чтобы убедиться,он работает только с числовыми значениями!

Таким образом, вы получите что-то вроде:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim MyPlage  As Range
    Set MyPlage = Intersect(Target, Target.Parent.Range("A:A"))

    If Not MyPlage Is Nothing Then
        Dim Cell As Range
        For Each Cell In MyPlage
            If Cell.Value = vbNullString Then
                Cell.Interior.ColorIndex = 3 'red
            ElseIf IsNumeric(Cell.Value) Then
                If Cell.Value < 1 Then
                    Cell.Interior.ColorIndex = 3 'red
                Else
                    Cell.Interior.ColorIndex = 4 'green
                End If
            End If
        Next Cell
    End If
End Sub

Answer 3

Вы можете использовать следующий макрос.Оно должно быть размещено в соответствующем рабочем листе (не в рабочей книге и не в модуле).Кроме того, вы можете определить диапазон для наблюдения, определив rngObserve).Я думаю, вы не хотите проверять весь лист ...

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngObserve As Range, rngCell As Range

Set rngObserve = Intersect(Target, Range("A1:C5"))

If rngObserve Is Nothing Then
    Exit Sub
End If
For Each rngCell In rngObserve.Cells
    If Not Intersect(rngCell, rngObserve) Is Nothing Then
        If rngCell.Value = vbNullString Then
            rngCell.Interior.Color = xlNone
        ElseIf rngCell.Value < 1 Then
            rngCell.Interior.ColorIndex = 3
        ElseIf rngCell.Value >= 1 Then
            rngCell.Interior.ColorIndex = 4
        Else
            rngCell.Interior.ColorIndex = 3
        End If
    End If
Next

End Sub