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

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贝娄使用＆＃34;反向＆＃34;的 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