Excel中 - 删除行，如果不包含在列表中值的一个

Question

我是新来的VBA，我想我最好解释一下我想要做的

我需要检查表1和表2 如果他们在行中有“AAA”或“BBB”或“CCC”的值，如果不是，则删除整行

我的下面的代码只能帮我删除行， AAA” Q列

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

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

3. 我实际上有10个值（AAA，BBB，CCC .... JJJ）想要保留，是否需要逐个输入，或者有一种方法要求excel 检查列表中，如果在表1，并与任何 一个从这些10个值匹配的表2中的任何细胞，保留该行，否则，删除整个 行

列表是在表3从塔A1定位：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，
删除行后个
• 重新显示PageBreaks，
• 几Exit For，以免发生维持循环，当你有足够的去
• 店单元格的值到一个变量来提高性能的同时对阵列的值测试

---

代码以除去在列表不含任何值的行：

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中的数据填充数组。如果添加更多值，则可以更改范围，或者更改代码以动态检查数组的大小应该是多少。 代码：

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