Question

我已经复制并粘贴了从一张纸到要编辑的一张纸的范围。该单元格区域具有行和列（当然）。我想要宏执行的操作是通过D列并检查单元格的背景色。如果除白色外还有背景色，我希望宏删除该单元格所属的整行。因此，作为最终结果，我希望宏仅保留D列中的单元格没有填充或白色背景色的行。下面提供的代码按预期的方式执行了该任务，但是花费了很多时间。宏处理的总行数为700。

到目前为止，我提供了两种不同类型的代码。他们俩都花了很长时间。

代码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

代码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

您应该使用代码2。关闭ScreenUpdating和Calculations将大大加快代码的速度。

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

我查找了Union东西，并修改了您的代码1。您也可以在此处选择包括屏幕更新和计算模式，但是由于删除仅发生在代码的末尾，因此对性能的影响不大。

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

（代码未经测试）

Answer 3

尝试以下代码：

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

我嵌套了If来模仿短路，这将增强代码的执行力。

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

3 个答案: