您的描述很差，但我试了一下。在“Sheet1”上试试这段代码。用第二个工作表的名称替换“Sheet2”。这将检查“Sheet2”上的每个工作，并删除Sheet1上B列包含该单词的所有行。不确定C列是什么意思，但该条件应该很容易添加。
告诉我。

Sub Test()

    Dim LastRow As Long
    Dim LastRowS2 As Long
    Dim Word As String

    LastRowS2 = ThisWorkbook.Sheets("Sheet2").Cells(1, 1).End(xlDown).Row
    LastRow = Cells(1, 1).End(xlDown).Row

    For i = 2 To LastRowS2
        For j = 2 To LastRow
            Word = Split(ThisWorkbook.Sheets("Sheet2").Cells(i, "A").Text, " ")(0)
            If InStr(Cells(j, "B").Text, Word) > 0 Then
                If InStr(Cells(j, "C").Text, Word) > 0 Then
                    'Do nothing
                Else
                    Cells(j, "B").EntireRow.Delete
                    j = j - 1
                End If
            End If
        Next j
    Next i

End Sub

按条件删除列

链接

Workbook Download
代码

Sub DeleteColumnCriteria()

    ' Worksheet 1
    Const csheet1 As Variant = "Sheet1"   ' Worksheet Name/Index
    Const cFirstR1 As Long = 2            ' First Row
    Const cCol1 As Variant = "B"          ' Criteria Column 1
    Const cCol2 As Variant = "C"          ' Criteria COlumn 2
    ' Worksheet 2
    Const cSheet2 As Variant = "Sheet2"   ' Worksheet Name/Index
    Const cFirstR2 As Long = 2            ' First Row
    Const cCol As Variant = "A"           ' Criteria Column

    ' Worksheet 1
    Dim rngU As Range     ' Union Range
    Dim LastR1 As Long    ' Last Row Number
    Dim i As Long         ' Row Counter
    ' Worksheet 2
    Dim ws2 As Worksheet  ' Worksheet 2
    Dim LastR2 As Long    ' Last Row Number
    Dim j As Long         ' Row Counter

    Application.ScreenUpdating = False

    ' Calculate Last Row of Worksheet 2.
    Set ws2 = ThisWorkbook.Worksheets(cSheet2)
    LastR2 = ws2.Cells(ws2.Rows.Count, cCol).End(xlUp).Row

    With ThisWorkbook.Worksheets(csheet1)

        ' Calculate Last Row of Worksheet 1.
        LastR1 = .Cells(.Rows.Count, cCol1).End(xlUp).Row

        ' Accumulate ranges into Union Range.
        For i = cFirstR2 To LastR2 ' Loop through rows in Worksheet 2.
            For j = cFirstR1 To LastR1  ' Loop through rows in Worksheet 1.
                ' When value in cCol in Worksheet 2 is equal to cCol1 and
                ' not in cCol2 in Worksheet 1.
                If ws2.Cells(i, cCol) <> "" Then
                    If ws2.Cells(i, cCol) = .Cells(j, cCol1) _
                            And ws2.Cells(i, cCol) <> .Cells(j, cCol2) Then
                        If Not rngU Is Nothing Then   ' All other times.
                            Set rngU = Union(rngU, .Cells(j, 1))
                          Else                        ' First time only.
                            Set rngU = .Cells(j, 1)
                        End If
                    End If
                End If
            Next
        Next

    End With

    ' Delete rows in one go.
    If Not rngU Is Nothing Then
        rngU.EntireRow.Delete ' Hidden = True
    End If

    Application.ScreenUpdating = True

End Sub