vba 根据内部颜色删除工作表中的所有单元格
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/9927090/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Delete all cells in a sheet based on interior color
提问by TLDAN
Range("A:A").Select
For Each Cell In Selection
If ActiveCell.Interior.Color = Excel.XlRgbColor.rgbOrange Then
cell.clear
End If
Next
回答by assylias
This should work better (in your code you were always checking the active cell):
这应该会更好（在您的代码中，您一直在检查活动单元格）：
Range("A:A").Select
For Each Cell In Selection
If cell.Interior.Color = Excel.XlRgbColor.rgbOrange Then
cell.clear
End If
Next
And you don't need to select the range so you could also write:
而且您不需要选择范围，因此您也可以编写：
For Each Cell In Range("A:A")
If cell.Interior.Color = Excel.XlRgbColor.rgbOrange Then
cell.clear
End If
Next
回答by brettdj
This code uses Findto quickly clear cells matching your desired format
此代码用于Find快速清除与您所需格式匹配的单元格
The line to update for other cell fromats is:.FindFormat.Interior.Color = Excel.XlRgbColor.rgbOrange
更新其他单元格 fromats 的行是：.FindFormat.Interior.Color = Excel.XlRgbColor.rgbOrange
Option Explicit
Sub FastFind()
Dim rng1 As Range
Dim rng2 As Range
Dim cel1 As Range
Dim strFirstAddress As String
Dim lAppCalc As Long
'Get working range from user
On Error Resume Next
Set rng1 = Application.InputBox("Please select range to search for ", "User range selection", Selection.Address(0, 0), , , , , 8)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
With Application
lAppCalc = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
.FindFormat.Interior.Color = Excel.XlRgbColor.rgbOrange
End With
Set cel1 = rng1.Find("", , xlValues, xlPart, xlByRows, , , , True)
If Not cel1 Is Nothing Then
Set rng2 = cel1
strFirstAddress = cel1.Address
Do
Set cel1 = rng1.Find("", cel1, xlValues, xlPart, xlByRows, , , , True)
Set rng2 = Union(rng2, cel1)
Loop While strFirstAddress <> cel1.Address
End If
If Not rng2 Is Nothing Then rng2.Clear
With Application
.ScreenUpdating = True
.Calculation = lAppCalc
End With
End Sub
