关于excel：如何根据单元格背景色删除行？


How to delete rows based on cell background color?

我将一系列单元格复制并粘贴到要编辑的单元格中。

我想遍历D列并检查每个单元格的背景色。如果除了白色以外还有其他颜色，我想删除该单元格所属的整行。

最终的结果是，我只保留D列中的单元格没有填充或白色背景色的行。

下面的代码执行了该任务，但是花费了很多时间。宏处理的总行数为700。

我提供两种不同类型的代码。他们俩都花了这么长时间。

代码1

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
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

1
2
3
4
5
6
7
8
9
10
11
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
相关讨论

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
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

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
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

(代码未经测试)

尝试此代码：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
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来模拟短路，这将增强代码的执行。

相关讨论