VBA脚本删除除过滤值之外的所有行

Question

我目前正在创建一个 VBA 脚本，我在其中提取原始数据列表并过滤掉 Apple、Banana 和 Oranges 的值。如果不是上面提到的值，我会删除所有其他行。

例如，我有苹果、香蕉、橙子、葡萄、柑橘、鳄梨、椰子、柠檬、西瓜。

最后我只想保留苹果、香蕉和橙子。如果它有任何其他水果，我希望删除整行信息。

Sub RMWO_Clean()

Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long


Set ws = ActiveWorkbook.Sheets("Sheet1")

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

Set rng = ws.Range("Q1:Q" & lastRow)


Columns("AF:AF").Select
Selection.TextToColumns Destination:=Range("AA1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True

With rng
.AutoFilter Field:=1,Criteria1:="<>*Apple*", Operator:=xlAnd, Criteria2:="<>*Banana*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With

ws.AutoFilterMode = False

End Sub

我知道你不能使用

Criteria3:=xx

我也试过了

Criteria1:=Array("<>Apple", "<>Banana", "<>Orange") 

但这似乎只留下橙色。

你能告诉我我做错了什么吗？

Answer 1

开始于：

我跑：

Dim myRange As Range
Set myRange = ActiveSheet.Range("$A$1:$A$4")

myRange.AutoFilter Field:=1, _
    Criteria1:="<>*Banana*", Operator:=xlAnd, Criteria2:="<>*apple*"

...我得到：

...然后我运行：

myRange.AutoFilter Field:=1

...我得到：

---

我可以删除未过滤的行：

Rows("2:7").Delete Shift:=xlUp

---

把它们放在一起，你可以做这样的事情：

Sub DeleteRowsExceptApplesAndBananas()

    Const startCell = "A1"
    Dim rgFilter As Range

    'get range to filter
    With Sheets("Sheet1")
        Set rgFilter = Range(.Range(startCell), .Range(startCell).End(xlDown))

        'set filter
        rgFilter.AutoFilter 1, "<>*Banana*", xlAnd, "<>*apple*"

        'delete rows beginning one below startCell's row
        Range(.Range(startCell).Offset(1).Row & ":" & _
            .Range(startCell).End(xlDown).Row).Delete (xlUp)

        'un-filter
        rgFilter.AutoFilter 1
    End With

End Sub

Answer 2

在我看来 Range.AutoFilter 不会做你想做的事，正是因为你只能使用两个标准。

我个人更喜欢用循环操作来解决这个问题，像这样：

    Option Compare Text

Sub Macro1()

    Dim ws As Worksheet
    Dim rng As Range
    Dim col As String
    Dim i As Integer

    Set ws = ActiveWorkbook.Sheets("Sheet1")
    col = "A"
    i = 1
    Set rng = ws.Range(col & i)

    Do

        Select Case rng.FormulaR1C1

            Case "apple", "orange", "banana"
                i = i + 1

            Case Else
                rng.Delete xlShiftUp

        End Select

        Set rng = ws.Range(col & i)

    Loop Until rng.FormulaR1C1 = ""

End Sub

上面的代码假定您已经完成了提取水果列表所需的所有预处理，并且该列表从 Sheet1 的单元格 A1 开始，尽管您当然可以修改该代码以放置您想要的任何地方的列表。

Answer 3

Criteria1:=Array("<>Apple", "<>Banana", "<>Orange") 需要 Operator:=xlFilterValues 运算符，但不能与 "<>" 一起使用

所以你可以反过来想办法来愚弄它：

• 过滤“好”记录

• 删除所有不好的记录

如下：

    With rng
        .AutoFilter Field:=1, Criteria1:=Array("Apple", "Banana", "Orange"), Operator:=xlFilterValues
        With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) ' reference 'records' only (skip headers)
            Select Case Application.Subtotal(103, .Cells) ' count number of filtered cells
                Case 0 'if no cells to save
                    .EntireRow.Delete ' delete all rows
                Case Is < .Count 'if there's at least one row to delete
                    Set saveRng = .SpecialCells(xlCellTypeVisible) ' store cells to save
                    .Parent.AutoFilterMode = False 'remove filter
                    saveRng.EntireRow.Hidden = True 'hide cells to save
                    .SpecialCells(xlCellTypeVisible).EntireRow.Delete 'delete visible cells
                    saveRng.EntireRow.Hidden = False 'bring cells to save visible back
            End Select
        End With
        .Parent.AutoFilterMode = False
    End With

Answer 4

下面的版本 1 使用“反向”AutoFilter

版本 2，移动所有行以保留到新工作表，并删除旧工作表（对于很多行非常快）

---

.

Version 1

---

Option Explicit

Public Sub DeleteRowsForCriteria()
    Const FILTER_COL = "Q"
    Const To_KEP = "apple banana orange"

    Dim ws As Worksheet, lr As Long

    Set ws = Sheet1     'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
    lr = ws.Cells(ws.Rows.Count, FILTER_COL).End(xlUp).Row

    Application.ScreenUpdating = False
    ws.Range("AF1:AF" & lr).TextToColumns Destination:=ws.Range("AA1"), _
                                          TextQualifier:=xlDoubleQuote, _
                                          FieldInfo:=Array(1, 1), _
                                          TrailingMinusNumbers:=True

    Dim filterCol As Range, toKep As Variant, keep As Range

    Set filterCol = ws.Range("Q1:Q" & lr)
    toKep = Split(To_KEP)

    With filterCol  'Reverse Filter - show all rows to keep ("apple banana orange")
        .AutoFilter Field:=1, Criteria1:=toKep, Operator:=xlFilterValues
        If .SpecialCells(xlCellTypeVisible).Count > 1 Then
            Set keep = .SpecialCells(xlCellTypeVisible).EntireRow
        End If
        .AutoFilter             'Unhide all rows
        keep.Rows.Hidden = True 'Hide all rows to keep ("apple banana orange")
        .SpecialCells(xlCellTypeVisible).EntireRow.Delete   'Delete unwanted (now visible)
    End With
    keep.Rows.Hidden = False    'Unhide rows to keep ("apple banana orange")
    Application.ScreenUpdating = True
End Sub

---

.

Version 2

---

Public Sub DeleteRowsForCriteriaFast()
    Const FILTER_COL = "Q"
    Const To_KEP = "apple banana orange"

    Dim ws1 As Worksheet, ws2 As Worksheet, lr As Long, wsName As String, keep As Range

    Set ws1 = Sheet1    'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
    lr = ws1.Cells(ws1.Rows.Count, FILTER_COL).End(xlUp).Row

    Application.ScreenUpdating = False
    ws1.Range("AF1:AF" & lr).TextToColumns Destination:=ws1.Range("AA1"), _
                                           TextQualifier:=xlDoubleQuote, _
                                           FieldInfo:=Array(1, 1), _
                                           TrailingMinusNumbers:=True
    Dim filterCol As Range, toKep As Variant

    Set filterCol = ws1.Range("Q1:Q" & lr)
    toKep = Split(To_KEP)
    Application.DisplayAlerts = False
    Set ws2 = ThisWorkbook.Worksheets.Add(After:=ws1)
    wsName = ws1.Name
    With filterCol
        .AutoFilter Field:=1, Criteria1:=toKep, Operator:=xlFilterValues
        If .SpecialCells(xlCellTypeVisible).Count > 1 Then
            .EntireRow.Copy
            ws2.Cells.PasteSpecial xlPasteColumnWidths
            ws2.Cells.PasteSpecial xlPasteAll           'Paste data on new sheet
            ws1.Delete: ws2.Name = wsName:  ws2.Cells(1).Select
        End If
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.CutCopyMode = False
End Sub

---

.

---

TextToColumns默认参数

• DataType:=xlDelimited
• ConsecutiveDelimiter:=False
• Tab:=False
• Semicolon:=False
• Comma:=False
• Space:=False
• Other:=False