Поиск данных из списка и удаление строки

Question

У меня есть таблица в Sheet1. Мне нужно искать в Sheet1 термины в Sheet2-ColumnA.

Список исключений в Sheet2-ColumnA не соответствует содержимому ячейки в Sheet1, но находится в содержимом ячейки (например: find "orange" в "желтый; оранжевый" или "оранжевый; желтый").

Если этот критерий найден, удалите строку. Если он не находит критерии, продолжайте вниз по списку, пока он не достигнет пустой ячейки.

Я записал один раунд этого, но мне нужно изменить его на l oop через весь список исключений пока он не достигнет пустой ячейки в списке исключений.

Sub ExclusionList()
'
' ExclusionList Macro
' Find terms from exclusion list and delete row
'
' Go to sheet2 and select first term in exclusion list
    Sheets("Sheet2").Select
    Range("A1").Select

' Copy cell contents and find in sheet 1
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Cells.Find(What:="orange", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate

' Delete row if found
    Application.CutCopyMode = False
    Selection.EntireRow.Delete
End Sub

В этом примере «оранжевый» является критерием на листе А1. Если можно пропустить копирование / вставку и обратиться непосредственно к списку исключений в функции Cells.Find (), похоже, что это очистит код и в целом будет более эффективным.

Answer 1

Попробуйте это.

Вот полезный ресурс на , избегающий выбора / активации . Это значительно сокращает код и делает его более эффективным.

Sub ExclusionList()

Dim r As Range, rFind As Range

With Sheets("Sheet2")
    For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp)) 'loop through every cell in sheet2 column A
        Set rFind = Sheets("Sheet1").Cells.Find(What:=r.Value, LookAt:=xlPart, MatchCase:=False, SearchFormat:=False)
        If Not rFind Is Nothing Then 'check that value is found to avoid error on next line
            rFind.EntireRow.Delete
        End If
    Next r
End With

End Sub