Окрашивание строк в 2 цвета

[yuldash]

Добрый день.
Задача такая. в таблице Excel в 4м столбце только 2 типа значений. 1 и 2. Надо покрасить строки со значением 1 в зеленый, а строки со значением 2 в желтый. Надо прописать в макросе.
у меня примерно получается, но окрашивает один раз и останавливается.
вот пример 

Код Выделить Развернуть

Sub Макрос1()
Dim rFoundRng As Range

    Set rFoundRng = Columns(4).Find(1)
    If Not rFoundRng Is Nothing Then
   Range(Cells(rFoundRng.Row, 1), Cells(rFoundRng.Row, 14)).Interior.ColorIndex = 6
    End If
   
Set rFoundRng = Columns(4).Find(2)
    If Not rFoundRng Is Nothing Then
   Range(Cells(rFoundRng.Row, 1), Cells(rFoundRng.Row, 14)).Interior.ColorIndex = 4
    End If
End Sub

[iron priest]

и зачем это делать через макрос?

[yuldash]

Слишком большая таблица

[iron priest]

мульён?

[yuldash]

мульён?

Да.
попытался цикл организовать - не получилось

[cheshiki1]

цикл, на мульёне не скажу как себя поведет, опыта мало.

Код Выделить Развернуть

Dim i%
For i = 2 To Cells(Rows.Count, 4).End(xlUp).Row
    Range(Cells(i, 1), Cells(i, 14)).Interior.ColorIndex = Choose(Cells(i, 4), 4, 6)
Next

[vikttur]

С массивом быстрее.
Сначала формируем диапазоны для заливки, в конце одним махом заливаем все строки:

Код Выделить Развернуть

Sub RngColor()
Dim ArrData
Dim rRng1 As Range, rRng2 As Range
Dim lRws As Long
Dim i As Long
    With ActiveSheet
        lRws = .UsedRange.Rows.Count
        If lRws < 2 Then Exit Sub
        ArrData = Range("D1:D" & lRws).Value ' значения столбца 4 в массив
       
        For i = 1 To lRws
            Select Case ArrData(i, 1) ' по значениям
                Case 1
                    If rRng1 Is Nothing Then
                        Set rRng1 = .Range(.Cells(i, 1), .Cells(i, 14)) ' формируем диапазон
                    Else
                        Set rRng1 = Union(rRng1, .Range(.Cells(i, 1), .Cells(i, 14))) 'пополняем диапазон
                    End If
                Case 2
                    If rRng2 Is Nothing Then
                        Set rRng2 = .Range(.Cells(i, 1), .Cells(i, 14))
                    Else
                        Set rRng2 = Union(rRng2, .Range(.Cells(i, 1), .Cells(i, 14)))
                    End If
            End Select
        Next i
   
        Application.ScreenUpdating = False
        .UsedRange.Interior.Pattern = xlNone ' удаление предыдущей заливки
        If Not rRng1 Is Nothing Then rRng1.Interior.ColorIndex = 6 ' красим диапазоны
        If Not rRng2 Is Nothing Then rRng2.Interior.ColorIndex = 4
        Application.ScreenUpdating = True
    End With
End Sub
В таком варианте обращения к листу минимальны -  только для получения данных в массив и для массовой заливки двух диапазонов.

[yuldash]

Спасибо, Попробую.
А как сделать, чтобы он автоматически все сделал?
например, я вбил новую строку, а он автоматически запускается

[cheshiki1]

посмотрите про событие Worksheet_Change