如何根据单元格背景颜色删除行？

Question

I copy and paste a range of cells from one sheet to one I want to edit.

I want to go through column D and check each cell's background color. If there is a color besides white, I want to delete the entire row that the cell belongs to.

As a final result I want to keep only rows in which the cell in column D has either no fill or white background color.

The code below performs that task, but takes so much time. The total number of rows that the macro processes is 700.

I provide two different types of code. Both of them take so long.

CODE 1

With ws1
    lastrow2 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    For i = lastrow2 To 2 Step -1
        nodel = False
        If .Cells(i, "D").Interior.ColorIndex = 2 Then
            nodel = True
        End If
        If .Cells(i, "D").Interior.ColorIndex = -4142 Then
            nodel = True
        End If
        If Not nodel Then
            .Rows(i).EntireRow.Delete
        End If
    Next i
End With

CODE 2

lastrow2 = ws1.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In ws1.Range("D2:D" & lastrow2)
    If Not cell.Interior.ColorIndex = 2 Or cell.Interior.ColorIndex = -4142 Then
        If DeleteRange Is Nothing Then
            Set DeleteRange = cell
        Else
            Set DeleteRange = Union(DeleteRange, cell)
        End If
    End If
Next cell
If Not DeleteRange Is Nothing Then DeleteRange.EntireRow.Delete

Answer 1

You should use Code 2. Turning off ScreenUpdating and Calculations will speed up the code tremendously.

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

lastrow2 = ws1.Range("A" & Rows.count).End(xlUp).Row
For Each cell In ws1.Range("D2:D" & lastrow2)
    If Not cell.Interior.ColorIndex = 2 Or cell.Interior.ColorIndex = -4142 Then
        If DeleteRange Is Nothing Then
            Set DeleteRange = cell
        Else
            Set DeleteRange = Union(DeleteRange, cell)
        End If
    End If
Next cell
If Not DeleteRange Is Nothing Then DeleteRange.EntireRow.Delete

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Answer 2

I looked up the Union thing, and adapted your code 1. You can choose to include the screenupdating, and calculation mode here as well, but as deletion only happens at the end of the code it shouldn't make much of a performance difference.

With ws1
    lastrow2 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    For i = lastrow2 To 2 Step -1
    If .Cells(i, "D").Interior.ColorIndex = 2 Or .Cells(i, "D").Interior.ColorIndex = -4142 Then
        Dim DeleteRange as range
        If DeleteRange Is Nothing Then
            Set DeleteRange = .Rows(i).entirerow
        Else
            Set DeleteRange = Union(DeleteRange, .Rows(i).entirerow)
        End If
    End If
    Next i
    DeleteRange.Delete
End With

(Code is untested)

Answer 3

Try this code:

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Dim DeleteRange As Range
With ws1
    lastrow2 = .Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lastrow2
        If Not .Cells(i, "D").Interior.ColorIndex = -4142 Then
            If Not .Cells(i, "D").Interior.ColorIndex = 2 Then
                If DeleteRange Is Nothing Then
                    Set DeleteRange = .Rows(i)
                Else
                    Set DeleteRange = Union(DeleteRange, .Rows(i))
                End If
            End If
        End If
    Next i
End With

DeleteRange.Delete

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

I nested If s to imitate short-circuiting, which will enhance execution of a code.