Excel VBA基于列中的多个条件删除整个行

Question

我正在尝试在excel中为vba编写宏。我想删除在D列（关键字为“INVOICE”，“PAYMENT”或“P.O.”）中没有至少三个关键字中的至少一个的每一行。我需要保持包含这些关键字的每一行。所有其他行都需要删除，剩下的行需要推送到文档的顶部。还有两个标题行无法删除。

我发现了下面的代码，但它删除了不包含“INVOICE”的每一行。我无法操作代码来执行我需要的操作。

Sub Test() 

    Dim ws As Worksheet 
    Dim rng1 As Range 
    Dim lastRow As Long 

    Set ws = ActiveWorkbook.Sheets("*Name of Worksheet") 

    lastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row 

    Set rng = ws.Range("D1:D" & lastRow) 

    ' filter and delete all but header row 
    With rng 
     .AutoFilter Field:=1, Criteria1:="<>*INVOICE*" 
     .Offset(2, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete 
    End With 

    ' turn off the filters 
    ws.AutoFilterMode = False 

End Sub 

Answer 1

我会对这个循环略有不同。对我来说，这是更容易阅读。

Sub Test() 

    Dim ws As Worksheet 
    Dim lastRow As Long, i As Long 
    Dim value As String 

    Set ws = ActiveWorkbook.Sheets("*Name of Worksheet") 
    lastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row 

    ' Evaluate each row for deletion. 
    ' Go in reverse order so indexes don't get messed up. 
    For i = lastRow To 2 Step -1 
     value = ws.Cells(i, 4).Value ' Column D value. 

     ' Check if it contains one of the keywords. 
     If Instr(value, "INVOICE") = 0 _ 
      And Instr(value, "PAYMENT") = 0 _ 
      And Instr(value, "P.O.") = 0 _ 
      Then 

      ' Protected values not found. Delete the row. 
      ws.Rows(i).Delete 
     End If 
    Next 

End Sub 

这里的关键是检查单元格值内受保护的关键字Instr function。如果找不到任何关键字，则满足If条件，并删除该行。

只需附加If条件即可轻松添加其他受保护的关键字。

Answer 2

'similar with previous post, but using "like" operator 

Sub test() 
    Dim ws As Worksheet, i&, lastRow&, value$ 
    Set ws = ActiveWorkbook.ActiveSheet 
    lastRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row 
    For i = lastRow To 2 Step -1 
     value = ws.Cells(i, 4).value 
     ' Check if it contains one of the keywords. 
     If Not (value Like "*INVOICE*" _ 
      Or value Like "*PAYMENT*" _ 
      Or value Like "*P.O.*") _ 
      Then 
      ' Protected values not found. Delete the row. 
      ws.Rows(i).Delete 
     End If 
    Next 
End Sub 

Answer 3

' 
Sub test() 
    Dim i& 
    Application.ScreenUpdating = False 
    i = Range("D" & Rows.Count).End(xlUp).Row 
    While i <> 1 
     With Cells(i, 4) 
      If Not (.value Like "*INVOICE*" _ 
       Or .value Like "*PAYMENT*" _ 
       Or .value Like "*P.O.*") _ 
       Then 
       Rows(i).Delete 
      End If 
     End With 
     i = i - 1 
    Wend 
    Application.ScreenUpdating = True 
End Sub 

Answer 4

的方式水净化处于工作列插入一个IF测试，然后AutoFilter这一点。

这是VBA相当于进入
=SUM(COUNTIF(D1,{"*INVOICE*","*PAYMENT*","*P.O.*"}))=0 ，然后删除其中没有这些值在corrresponing D细胞

Sub QuickKill() 
    Dim rng1 As Range, rng2 As Range, rng3 As Range 
    Set rng1 = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious) 
    Set rng2 = Cells.Find("*", , xlValues, , xlByRows, xlPrevious) 
    Set rng3 = Range(Cells(rng2.Row, rng1.Column), Cells(1, rng1.Column)) 

    Application.ScreenUpdating = False 
    Rows(1).Insert 

    With rng3.Offset(-1, 1).Resize(rng3.Rows.Count + 1, 1) 
     .FormulaR1C1 = "=SUM(COUNTIF(RC[-1],{""*INVOICE*"",""*PAYMENT*"",""*P.O.*""}))=0" 
     .AutoFilter Field:=1, Criteria1:="TRUE" 
     .EntireRow.Delete 
     On Error Resume Next 
     'in case all rows have been deleted 
     .EntireColumn.Delete 
     On Error GoTo 0 
    End With 

    Application.ScreenUpdating = True 
End Sub