Удаление строк по цвету заливки

[strannick]

Добрый день, уважаемые форумчане!
Имеется лист, в котором строки залиты разными цветами (во вложении). Имеется вот такой макрос, который проверяет ячейки Столбца А и, если залиты темно-зеленым цветом, то удаляет строку:

Sub Макрос2()
Dim sh As Worksheet, i As Long
  Set sh = Sheets("CSV")
  For i = sh.Cells(Rows.Count, 1).End(xlUp).row To 1 Step -1
  If sh.Cells(i, 1).Interior.ColorIndex <> 10 Then Cells(i, 1).EntireRow.Delete (xlShiftUp)
  Next i
End Sub

Или не тот индекс, или я дальтоник. Рассудите.
Заранее спасибо!

[nilem]

У Вас в 1-м столбце нет данных, поэтому sh.Cells(Rows.Count, 1).End(xlUp).row=1. Если так и должно быть, то попробуйте:

Sub Макрос2()
Dim sh As Worksheet, i As Long
Set sh = Sheets("CSV")
With sh.UsedRange.Columns(1)
    For i = .Rows.Count To 1 Step -1
        With .Cells(i)
            If .Interior.ColorIndex = 14 Then .EntireRow.Delete
        End With
    Next i
End With
End Sub

[strannick]

Спасибо, порядок! Только я не правильно написал в начале. Не удалить строки, залитые темно-зеленым цветом, а удалить все, кроме залитых темно -зеленым цветом. Ну, тут понятно, что должно быть:

If .Interior.ColorIndex <> 14 Then .EntireRow.Delete

Только вот не пойму, у темно-зеленого индекс 14?

[VictorM]

Только вот не пойму, у темно-зеленого индекс 14?

Похоже, да.
Только он не совсем чтобы т.зеленый.
Вот простенький, без изысков, макрос

Sub ЗаполнитьЦвет()
       [a1].Select
    n = 56
    For i = 1 To n
        Application.ScreenUpdating = False
        ActiveCell.Interior.ColorIndex = i
        ActiveCell.Offset(0, 1) = "Interior.ColorIndex =" & i
        ActiveCell.Offset(1, 0).Activate
    Next i
    Application.ScreenUpdating = True
    [a1].Select
End Sub

[strannick]

Спасибо! Работают все (и мой тоже) с индексом 14. Странно как-то цвет брался из стандартных цветов экселя. Перепробовал и 4, и 2, и 10. С красным работал нормально. А тут...
Пришел бы kuklp, так сразу бы отфильтровал бы все. А У меня чего-то с автофильтром нелады.
Еще раз спасибо!

[staniiislav]

Можно еще таким макаром:

Sub Del_Cell_Green()
    Dim i As Long
    Application.ScreenUpdating = False
    On Error Resume Next
    'i = Cells(Rows.Count, 1).End(xlUp).Row
    i = 1000
    Range("A1:A" & i).AutoFilter Field:=1, Criteria1:=RGB(0, 176, 80), Operator:=xlFilterCellColor
    Range("A2:A" & i).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Range("A1:A" & i).AutoFilter = False

    Application.ScreenUpdating = True
End Sub

только поиск последней строки раз комментируйте, а

i=1000

удалите

[DiemonStar]

staniiislav,
это сработает, если человек не пользуется автофильтром)

[staniiislav]

Сообщение от DiemonStar

staniiislav,
это сработает, если человек не пользуется автофильтром)

согласен, но в файле автофильтры я не увидел.
Но можно еще убрать строку удаления филтра, а поставить просто сброс фильтра

[staniiislav]

вот так будет выглядеть с проверкой на наличие фильтров:

Sub Del_Cell_Green()
    Dim i As Long
    Application.ScreenUpdating = False
    On Error Resume Next
        With ActiveSheet
            'i = .Cells(Rows.Count, 1).End(xlUp).Row
            i = 1000
            If .AutoFilter.Filters(1).On Then
                .Range("A1:A" & i).AutoFilter Field:=1, Criteria1:=RGB(0, 176, 80), Operator:=xlFilterCellColor
                .Range("A2:A" & i).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                .Range("A1:A" & i).AutoFilter = False
            Else
                .Range("A1:A" & i).AutoFilter Field:=1, Criteria1:=RGB(0, 176, 80), Operator:=xlFilterCellColor
                .Range("A2:A" & i).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                .Range("A1:A" & i).AutoFilter Field:=1
            End If
        End With
    Application.ScreenUpdating = True
End Sub

[strannick]

Автофильтра там и не планировалось. А я как раз об этом и думал. Поставил фильтр, отфильтровал, удалил, убрал фильтр. Спасибо staniiislav!