先发一下吧~可能哪位大神路过呢

Option Explicit

Sub 执行任务()
    Dim def As Object '【结构】数据：字典，KEYA+KEYB -> ARRAY(arrInc, arrExc)
    Dim arrKey1, arrKey2, arrResult '关键字，未分配关键字，生成结果：二维表
    Dim arr, i&, j&, x&, vKey, strInc$, strExc$, arrInc, arrExc, isInc, isExc, t '临时变量
   
    '读【结构】
    Set def = CreateObject("Scripting.Dictionary")
    arr = Sheets("结构").Range("a1").CurrentRegion '表1
    x = 0 '【排除所包含的词根】在第一行的列序号
    For j = 3 To UBound(arr, 2)
        If Left(arr(1, j), 2) = "排除" Then
            x = j
            Exit For
        End If
    Next j
    For i = 2 To UBound(arr)
        If arr(i, 1) <> "" And arr(i, 2) <> "" Then
            vKey = arr(i, 1) & vbTab & arr(i, 2)
            strInc = "" '包含
            strExc = "" '排除
            For j = 3 To UBound(arr, 2)
                If arr(i, j) <> "" Then
                    If j < x Then strInc = strInc & vbTab & arr(i, j) Else strExc = strExc & vbTab & arr(i, j)
                End If
            Next j
            If strInc = "" Then arrInc = Array() Else arrInc = Split(Mid(strInc, 2), vbTab)
            If strExc = "" Then arrExc = Array() Else arrExc = Split(Mid(strExc, 2), vbTab)
            def(vKey) = Array(arrInc, arrExc)
        End If
    Next i
   
    '读【关键字】
    With Sheets("关健词") '表2
        arrKey1 = .Range(.Cells(2, 1), .Cells(.Rows.Count, "A").End(xlUp))
    End With
   
    '进行筛选1，生成 结果
    ReDim arrResult(1 To UBound(arrKey1), 1 To 3)
    x = 0
    For i = 1 To UBound(arrKey1)
        For Each vKey In def.Keys
            isInc = False
            For Each t In def(vKey)(0)
                If arrKey1(i, 1) = t Then '假设完全匹配，部分匹配需要修改为 InStr
                    isInc = True
                    Exit For
                End If
            Next t
            isExc = False
            For Each t In def(vKey)(1)
                If InStr(arrKey1(i, 1), t) > 0 Then '假设部分匹配， 完全匹配需要修改为 =
                    isExc = True
                    Exit For
                End If
            Next t
            If isInc And Not isExc Then
                x = x + 1
                t = Split(vKey, vbTab)
                arrResult(x, 1) = t(0)
                arrResult(x, 2) = t(1)
                arrResult(x, 3) = arrKey1(i, 1)
                arrKey1(i, 1) = ""
                Exit For '关键字匹配一个结构就跳出，无需继续判断
            End If
        Next vKey
    Next i
    With Sheets("生成后") '表3
        .Range("A2").Resize(.UsedRange.Rows.Count, 3).ClearContents
        .Range("A2").Resize(x, 3) = arrResult
    End With
   
    '进行筛选2，生成 未匹配
    ReDim arrKey2(1 To UBound(arrKey1), 1 To 1)
    x = 0
    For i = 1 To UBound(arrKey1)
        If arrKey1(i, 1) <> "" Then
            x = x + 1
            arrKey2(x, 1) = arrKey1(i, 1)
        End If
    Next i
    With Sheets("关健词") '表2
        .Range("B2").Resize(.UsedRange.Rows.Count, 1).ClearContents
        .Range("B2").Resize(x, 1) = arrKey2
    End With
End Sub

            isInc = False
            For Each t In def(vKey)(0)
                If arrKey1(i, 1) = t Then '假设完全匹配，部分匹配需要修改为 InStr
                    isInc = True
                    Exit For
                End If
            Next t
            isExc = False
            For Each t In def(vKey)(1)
                If InStr(arrKey1(i, 1), t) > 0 Then '假设部分匹配， 完全匹配需要修改为 =
                    isExc = True
                    Exit For
                End If
            Next t