Скрипт 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

Версия 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

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

Приведенный выше код предполагает, что вы уже выполнили всю предварительную обработку, необходимую длясделать, чтобы извлечь свой список фруктов, и этот список начинается в ячейке A1 листа Sheet1, хотя вы, конечно, можете изменить этот код, чтобы разместить список в любом месте вы хотите.

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

Начиная с:

Я бегу:

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