Macro to Delete Rows with Fill Color

Hi,

I found and was able to modify a macro to delete rows with specific fill color. The problem is that on any given day I could be running this on 25-100K rows and the macro is fairly slow. I was just wondering if anybody had a better option or if it is possible to "speed up" a macro.

The code I have is:
Sub GreyRows()
Dim rng As Range

Set rng = Intersect(Range("E:E"), ActiveSheet.UsedRange)

For x = rng.Count To 1 Step -1
If rng(x).Interior.ColorIndex = 48 Then
rng(x).EntireRow.Delete
End If
Next


End Sub


Thanks in advance for anybody looking at this,

Brenda

Hi:

You can use the filter property of excel if do not want to loop through

Sub Test()
    Range("A1").AutoFilter
    ActiveSheet.Range("$A$1:$A$1").AutoFilter Field:=1, Criteria1:=RGB(255, 255 _
    , 0), Operator:=xlFilterCellColor
    ActiveSheet.Range("$A$1:$A$16").Offset(1, 0).SpecialCells _
    (xlCellTypeVisible).EntireRow.Delete
End Sub

Note: You will have to tweak the RGB and Range to suit your needs.

Thanks

Hi, Nebu

Thanks.
Changed the code to the following but hanging up at: (xlCellTypeVisible).EntireRow.Delete



Sub Test()
Range("E3").AutoFilter
ActiveSheet.Range("E:E").AutoFilter Field:=1, Criteria1:=RGB(156, 156 _
, 156), Operator:=xlFilterCellColor
ActiveSheet.Range("E3:E100000").Offset(2, 0).SpecialCells
(xlCellTypeVisible).EntireRow.Delete
End Sub

Any ideas?

Hi:

I am not sure why it is hanging at your end, try the following

At the starting of the subroutine give the following.

Application.Calculation = xlCalculationManual
Application.SCreenUpdating=False

and at the end

Application.Calculation = xlCalculationAutomatic
Application.SCreenUpdating=True

Thanks