指定した約1000のキーワードを含む行以外を削除したいです

標準モジュールに以下のコードを貼り付けて、Sheet1 を表示している状態で delete_by_keyword_list2 サブルーチンを実行してください。

Sub delete_by_keyword_list2()
    On Error GoTo ErrorHandler

    Application.ScreenUpdating = False

    Dim keyword(), work()

    Set ref_s = Sheets("Sheet2")

    ' C列の最終行を調べる
    last_row = ref_s.Cells(Rows.Count, 3).End(xlUp).Row

    ReDim work(last_row)
    i = 1
    For r = 1 To last_row
        Set cell = ref_s.Cells(r, 3)
        If Not IsEmpty(cell) And cell.Value <> "" Then
            work(i) = cell.Value
            i = i + 1
        End If
    Next

    n = i - 1
    ReDim keyword(1 To n)
    For i = 1 To n
        keyword(i) = work(i)
    Next

    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = Join(keyword, "|")

    ' A列の最終行を調べる
    last_row = Cells(Rows.Count, 1).End(xlUp).Row

    r = 2
    Do While r <= last_row
        deleted = False
        txt = Cells(r, 1).Value
        If Not re.Test(txt) Then        ' ★基本的には、ここを変えただけ
            Cells(r, 1).EntireRow.Delete
            last_row = last_row - 1
        Else
            r = r + 1
        End If
        DoEvents
    Loop

FINAL:
    Set re = Nothing
    Application.ScreenUpdating = True

    Exit Sub

ErrorHandler:
    MsgBox "エラー！"
    GoTo FINAL

End Sub

前回の質問のコードでうまく行ったということなので、正規表現を使ったパターンでやってます。
if 文の条件を反転させただけなのですが、条件が判定すると削除する行の数も反転します。
前回のケースで多いのか、今回の方が多いのかが分からないので、画面表示の更新を止めて、少し早く動作するようにしてみました。

特別に速くはない数年前のノートPC で、キーワードが 1000件、対象のデータが 9000件、削除されるデータが 8900件程度というテストデータで試したところ、40秒くらいで削除が完了しました。
画面更新を活かしたままだと、3分近くかかります　(´・ω・｀)