Sub Del_Array_SubStr()
    Dim sSubStr As String    'искомое слово или фраза
    Dim lCol As Long    'номер столбца с просматриваемыми значениями
    Dim lLastRow As Long, li As Long
    Dim avArr, lr As Long
 
    lCol = Val(InputBox("Укажите номер столбца, в котором искать указанное значение", "Запрос параметра", 1))
    If lCol = 0 Then Exit Sub
    Application.ScreenUpdating = 0
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    'Получаем с Лист2 значения, которые надо удалить в активном листе
    With Sheets("Лист2") 'Имя листа с диапазоном значений на удаление
        avArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
    'удаляем
    For lr = 1 To UBound(avArr, 1)
        sSubStr = avArr(lr, 1)
        For li = lLastRow To 1 Step -1
            If CStr(Cells(li, lCol)) = sSubStr Then Rows(li).Delete
        Next li
    Next lr
    Application.ScreenUpdating = 1
End Sub

Sub t()
    Set Sh1 = Sheets(1)
    Set sh2 = Sheets(2)
    lrow1 = Sh1.Cells(Sh1.Rows.Count, "A").End(xlUp).Row
    lrow2 = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row
    j = 1
        Do While j <= lrow2
            sh2.Cells(j, 2).FormulaR1C1 = "=COUNTIF(Лист1!C1,Лист2!RC[-1])"
            If sh2.Cells(j, 2) = 0 Then
                sh2.Rows(j).Delete
                row2 = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row
            Else:
                sh2.Cells(j, 2).Clear
                j = j + 1
            End If
        Loop
End Sub

Sub DelIfNotExist()
    Dim arr, dic As Object, rr As Range, lr As Long, s As String, lLastR As Long
    Application.ScreenUpdating = 0
    
    Set dic = CreateObject("scripting.dictionary")
    dic.comparemode = 1
    With Sheets("Лист4") 'Имя листа с диапазоном значений на удаление
        arr = .Range(.Cells(5, 8), .Cells(.Rows.Count, 8).End(xlUp))
    End With
    For lr = 1 To UBound(arr, 1)
        s = arr(lr, 1)
        s = Trim(s)
        If Len(s) Then
            If dic.exists(s) = False Then
                dic.Add s, 0&
            End If
        End If
    Next
    'удаляем с листа2
    With Sheets("Лист6")
        arr = .Range(.Cells(11, 8), .Cells(.Rows.Count, 8).End(xlUp))
        For lr = 1 To UBound(arr, 1)
            s = arr(lr, 1)
            s = Trim(s)
            If Len(s) Then
                If dic.exists(s) = False Then
                    If rr Is Nothing Then
                        Set rr = .Cells(lr, 1)
                    Else
                        Set rr = Union(rr, .Cells(lr, 1))
                    End If
                End If
            End If
        Next
    End With
    If Not rr Is Nothing Then
        rr.EntireRow.Delete
    End If
    Application.ScreenUpdating = 1
End Sub