如果不包含列表中的值之一，则删除行

Question

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

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

我下面的代码只能帮助我删除行，除非它在 ​​Q 列中包含“AAA”

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

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

3. 我其实有10个值(AAA, BBB, CCC .... JJJ) 想保留，需要一个一个打出来，还是有方法问excel 检查列表，如果表 1 和表 2 中的任何单元格与任何匹配 这 10 个值中的一个，保留该行，否则，删除整个 行

列表位于 A1 列的第 3 页：A10

谢谢！ 我的代码如下

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,
• 删除行后重新显示分页符，
• 很少Exit Fors 以避免在您有足够的时间继续循环时保持循环
• 将单元格的值存储到变量中以提高性能，同时针对数组的值进行测试

---

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

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

您可以尝试使用数组来检查您要查找的值是否存在。 sub "FillArray" 用表 3 中的数据填充数组。如果添加更多值，则可以更改范围，或者更改代码以动态检查数组的大小。 代码：

   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