Excel – 如果不包含列表中的某个值，则删除行

我是VBA新手，我正在尽力解释我想要做什么

我需要检查表1和表2，如果他们有值“AAA”或“BBB”或“CCC”的行，我想保留它，如果没有，删除整个行

我的下面的代码只能帮我删除列中包含“AAA”Q行

1. 我不知道如何添加更多的值，如“BBB”和“CCC”，如果行有这些值，任一，我想保留它

2. 如何添加更多列来检查？ 现在只是在列Q中检查，如果我想检查从列H到R？

3. 我实际上有10个值（AAA，BBB，CCC …. JJJ）要保留，我是否需要逐个input，或者有一个方法要求excel检查列表，如果Sheet 1和Sheet 2与这10个值中的任何一个匹配，保留该行，否则删除整行

该列表位于A1：A10的表3中

谢谢 ！ 我的代码如下

Sub RemoveCell() Dim Firstrow As Long Dim Lastrow As Long Dim Lrow As Long Dim CalcMode As Long Dim ViewMode As Long With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With With Sheets("Sheet1") .Select ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView .DisplayPageBreaks = False 'Set the first and last row to loop through Firstrow = .UsedRange.Cells(1).Row Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row 'loop from Lastrow to Firstrow (bottom to top) For Lrow = Lastrow To Firstrow Step -1 With .Cells(Lrow, "Q") If Not IsError(.Value) Then If .Value <> "AAA" Then .EntireRow.Delete End If End With Next Lrow End With ActiveWindow.View = ViewMode With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub 

Answer 1

在这里，你只需要像这样使用它 ：

 Sub Test_CheL() '''Tune the parameters to fit your need : Sheet1 and AAA/BBB/CCC/JJJ Call DeleteRowsNotContaining(ThisWorkbook.Sheets("Sheet1"), "AAA/BBB/CCC/JJJ") End Sub 

---

我已经添加了一些东西来提高性能和稳定性：

• EnableEvents = False ，
• 删除行后重新显示PageBreaks，
• 几个Exit For当你有足够的时间来避免循环
• 将单元格的值存储到variables中以提高性能，同时根据数组的值进行testing

---

删除不包含列表中任何值的行的代码 ：

 Sub DeleteRowsNotContaining(wS As Worksheet, ValuesToKeep As String) Dim FirstRow As Long Dim LastRow As Long Dim LastColInRow As Long Dim LoopRow As Long Dim CalcMode As Long Dim ViewMode As Long Dim VtK() As String Dim i As Integer Dim KeepRow As Boolean Dim CelRg As Range Dim CelStr As String With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With VtK = Split(ValuesToKeep, "/") With wS .Select ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView .DisplayPageBreaks = False '''Set the first and last row to loop through FirstRow = .UsedRange.Cells(1, 1).Row LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row '''Loop from Lastrow to Firstrow (bottom to top) For LoopRow = LastRow To FirstRow Step -1 '''If you don't find any of your values, delete the row KeepRow = False LastColInRow = .Cells(LoopRow, .Columns.Count).End(xlToLeft).Column With .Range(.Cells(LoopRow, "A"), .Cells(LoopRow, LastColInRow)) For Each CelRg In .Cells '''If cell contains an error, go directly to the next cell If IsError(CelRg.Value) Then Else CelStr = CStr(CelRg.Value) For i = LBound(VtK) To UBound(VtK) If CelStr <> VtK(i) Then Else '''Cell contains a value to keep KeepRow = True Exit For End If Next i '''If you already found a value you want to keep, go next line If KeepRow Then Exit For End If Next CelRg '''Check if you need to delete the row If Not KeepRow Then .EntireRow.Delete End With '.Range(.Cells(LoopRow, "A"), .Cells(LoopRow, LastColInRow)) Next LoopRow .DisplayPageBreaks = True End With 'wS ActiveWindow.View = ViewMode With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub 

Answer 2

您可以尝试使用数组来检查您正在查找的值是否存在。 子“FillArray”用表3中的数据填充数组。如果添加更多值，则可以更改范围，也可以更改代码以dynamic检查数组的大小。 码：

  Dim arr(9) As Variant Sub RemoveCell() Dim Firstrow As Long Dim Lastrow As Long Dim Lrow As Long Dim CalcMode As Long Dim ViewMode As Long Dim colsTocheck As Integer With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With Call FillArray With Sheets("Sheet1") .Select ViewMode = ActiveWindow.View ActiveWindow.View = xlNormalView .DisplayPageBreaks = False 'Set the first and last row to loop through Firstrow = .UsedRange.Cells(1).Row Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row 'loop from Lastrow to Firstrow (bottom to top) For Lrow = Lastrow To Firstrow Step -1 deleteRow = False For colsTocheck = 8 To 18 '8 is H 18 is R - i find it easier to use column numbers With .Cells(Lrow, colsTocheck) If IsError(.Value) = False And .Value <> "" Then If IsInArray(.Value, arr) Then deleteRow = False Exit For Else deleteRow = True End If End If End With Next colsTocheck If deleteRow Then .Cells(Lrow, colsTocheck).EntireRow.Delete Next Lrow End With ActiveWindow.View = ViewMode With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean 'chceck if value is in array IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1) End Function Sub FillArray() 'fill array with values to check against Dim sList As Worksheet Set sList = Sheets("Sheet3") For i = 0 To 9 arr(i) = sList.Cells(i + 1, 1) Next i End Sub