这可能会快一点。将值加载到内存中，然后决定在那里保存什么。

Sub QuickDelete()
    Dim origData As Range
    With ThisWorkbook.Sheets("Graphs")
        Set origData = Intersect( _
            .UsedRange, _
            .Range(.Range("A4"), .Range("A" & .Rows.Count).End(xlUp)).EntireRow)
    End With
    
    Dim maxCols As Long
    maxCols = origData.Columns.Count
    
    Dim origVals() As Variant
    origVals = origData.Formula
    
    Dim keepRows As New Collection
    
    Dim maxRows As Long
    maxRows = UBound(origVals, 1)
    
'   Select data
    Dim i As Long
    For i = 1 To maxRows
        If IsError(origVals(i, 1)) Then keepRows.Add i
    Next i
    
'   Copy data
    Dim newVals() As Variant
    ReDim newVals(1 To keepRows.Count, 1 To maxCols)
    
    Dim j As Long
    Dim cpRow As Long
    For i = 1 To keepRows.Count
        cpRow = keepRows(i)
        For j = 1 To maxCols
            newVals(i, j) = origVals(cpRow, j)
        Next j
    Next i
    
'   Clear old data and paste new
    origData.ClearContents
    origData.Resize(keepRows.Count, maxCols).Formula = newVals
End Sub

使用AutoFilter高效删除条件行

Sub DeleteCriteriaRows()

    Const PROC_TITLE As String = "Delete Criteria Rows"
    
    Const SRC_NAME As String = "Graphs"
    Const SRC_FIRST_CELL As String = "Q31"
    Const DST_NAME As String = "Projects"
    Const DST_FIRST_CELL As String = "A3"
    Const DST_CRIT_COL As Long = 1
    Const DST_FLAG_STRING As String = "!|!"

    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim dict As Object
    Set dict = DictSingleColumnRange(wb, SRC_NAME, SRC_FIRST_CELL)
    If dict Is Nothing Then Exit Sub
        
    Dim fRows As Long: fRows = DeleteMultiCriteriaRows( _
        wb, DST_NAME, DST_FIRST_CELL, DST_CRIT_COL, dict, DST_FLAG_STRING)
        
    If fRows > 0 Then
        MsgBox fRows & " row" & IIf(fRows = 1, "", "s") & " deleted.", _
            vbInformation, PROC_TITLE
    End If
    
End Sub

Function DictSingleColumnRange( _
    ByVal wb As Workbook, _
    ByVal WorksheetName As String, _
    ByVal FirstCell As String) _
As Object
    Const PROC_TITLE As String = "Single Column Range To Dictionary"
    On Error GoTo ClearError

    Dim ws As Worksheet: Set ws = wb.Sheets(WorksheetName)
    If ws.FilterMode Then ws.ShowAllData
    
    Dim rg As Range, rCount As Long
    
    With ws.Range(FirstCell)
        Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not lCell Is Nothing Then
            rCount = lCell.Row - .Row + 1
            Set rg = .Resize(rCount)
        End If
    End With
    
    If rg Is Nothing Then
        MsgBox "No data found!", vbCritical, PROC_TITLE
        Exit Function
    End If
    
    Dim Data()
    
    If rCount = 1 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
    Else
        Data = rg.Value
    End If
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim r As Long, rString As String
    
    For r = 1 To rCount
        rString = CStr(Data(r, 1))
        If Len(rString) > 0 Then dict(rString) = Empty
    Next r
    
    If dict.Count = 0 Then
        MsgBox "Only blank cells found!", vbCritical, PROC_TITLE
        Exit Function
    End If
    
    Set DictSingleColumnRange = dict

ProcExit:
    Exit Function
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Function

Function DeleteMultiCriteriaRows( _
    ByVal wb As Workbook, _
    ByVal WorksheetName As String, _
    ByVal FirstCell As String, _
    ByVal CriteriaColumn As Long, _
    ByVal CriteriaDictionary As Object, _
    Optional ByVal FlagString As String = "!|!") _
As Long
    Const PROC_TITLE As String = "Delete Multi-Criteria Rows"
    On Error GoTo ClearError

    Dim ws As Worksheet: Set ws = wb.Sheets(WorksheetName)
    If ws.FilterMode Then ws.ShowAllData
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim rg As Range
    
    With ws.Range(FirstCell)
        Set rg = Intersect(.EntireRow.Resize(ws.Rows.Count - .Row + 1), _
            ws.UsedRange)
    End With
    
    If rg Is Nothing Then
        MsgBox "No data found.", vbCritical, PROC_TITLE
        Exit Function
    End If
    
    Dim rCount As Long: rCount = rg.Rows.Count - 1
    Dim cCount As Long: cCount = rg.Columns.Count
        
    If rCount = 0 Then
        MsgBox "Only headers found.", vbCritical, PROC_TITLE
        Exit Function
    End If
    
    ' Flag criteria column.
    
    Dim fRows As Long, WasFlagged As Boolean
    
    With rg.Resize(rCount).Offset(1)
        With rg.Columns(CriteriaColumn)
            Dim Data(): Data = .Value
            Dim r As Long
            For r = 1 To rCount
                If CriteriaDictionary.Exists(CStr(Data(r, 1))) Then
                    Data(r, 1) = FlagString
                    fRows = fRows + 1
                    WasFlagged = True
                End If
            Next r
            If WasFlagged Then .Value = Data
        End With
    End With
    
    If Not WasFlagged Then
        MsgBox "No criteria found.", vbExclamation, PROC_TITLE
        Exit Function
    End If
        
    ' Expand the range by one column to hold an ascending integer sequence.
    
    cCount = cCount + 1
    Set rg = rg.Resize(, cCount)
    
    ' Delete rows and clean up.
    
    Application.ScreenUpdating = False
    
    With rg.Resize(rCount).Offset(1)
        
        ' Write an ascending integer sequence to the added column.
        .Columns(cCount).Value = ws.Evaluate("ROW(1:" & rCount & ")")
        ' Sort by the criteria column to end up with a single filtered area.
        .Sort .Columns(CriteriaColumn), xlAscending, , , , , , xlNo
    
        ' Delete filtered rows.
        rg.AutoFilter CriteriaColumn, FlagString
        Dim dfrg As Range: Set dfrg = .SpecialCells(xlCellTypeVisible)
        ws.AutoFilterMode = False
        dfrg.Delete xlShiftUp
        
        ' Sort by the added column to restore initial order.
        .Sort .Columns(cCount), xlAscending, , , , , , xlNo
        ' Clear the added column.
        .Columns(cCount).ClearContents
    
    End With

    DeleteMultiCriteriaRows = fRows

ProcExit:
    If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
    Exit Function
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Function

只使用Union运行一次删除..类似这样的东西....（我没有测试）

Dim Firstrow As Long
Dim Lastrow As Long
Dim lrow As Long

Set wsGraphs = ThisWorkbook.Sheets("Graphs")

With ThisWorkbook.Sheets("Projects")

'Set the first and last row to loop through
Firstrow = 4
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row

dim killRange as range
For lrow = Lastrow To Firstrow Step -1

        'Check the values in column A.
        With .Cells(lrow, "A")
            If Not IsError(Application.Match(.Value, wsGraphs.Range("Q31:Q" & xLR), 0)) Then
    if killRange is nothing then 
           set killRange = .entireRow
     else
           set killRange = Union(KillRange,.EntireRow)

            End If
        End With
    Next lrow
End With

if not KillRange is Nothing then
       killRange.Delete
End if

如果我理解正确的话，另一种方式是这样的：

Sub test()
startTimer = Timer
Application.ScreenUpdating = False
Dim rgCrit As Range: Dim cell As Range: Dim rgU As Range

With Sheets("Graphs")
    Set rgCrit = .Range("Q31", .Range("Q31").End(xlDown))
End With

For Each cell In rgCrit
    With Sheets("Projects").Columns(1)
        If Not .Find(cell.Value) Is Nothing Then
        .Replace cell.Value, True, xlWhole, , False, , False, False
        If rgU Is Nothing Then Set rgU = .SpecialCells(xlConstants, xlLogical) Else Set rgU = Union(rgU, .SpecialCells(xlConstants, xlLogical))
        .Replace True, cell.Value, xlWhole, , False, , False, False
        End If
    End With
Next

rgU.Select
'rgU.EntireRow.Delete

MsgBox Timer - startTimer

End Sub

rgCrit是要删除的类别的变化列表的范围，从单元格Q31开始到工作表Graphs中的任何行。
sub不会循环到工作表Projects的列A中的每个单元格，而是循环到rgCrit中的每个单元格，以获取工作表Projects列A中的所有行，其中循环单元格的值作为rgU变量。
循环结束后，它选择rgU，这样您就可以检查要删除的行是否在选择中。
如果发现选择正确，则可以删除rgU.select行并使用rgU.entirerow.delete
但不确定这种代码是否能给予你更快地处理。