以下图解

好像功能都已经实现，各按钮都可以动作，这是一个分享贴吗

终于有人回复了，老师，归类功能可以，就是排除这个功能没有实显。老师，像这个可以实显吗，这啥结贴了。

就是包含排除的词根，不归类，还是显示未分配里面。就像这些是一样。
石榴
梅花不喜欢
桃很好吃
牡丹国花
海棠没见过
玉兰油吗
春兰石榴
我也不喜欢吃桃
金鱼草
金鱼
这是金鱼草还是金鱼
绣球花是绣花球吗
龟背竹乌龟
青罗乌龟
乌龟背龟背竹

[此贴子已经被作者于2023-5-19 12:21编辑过]

你的需求一个字都没有描述，请看发帖的图，看看我猜对没有：

需求：
    把表2中“关键字”（A列）的单元格按照表1“结构”进行筛选，符合条件的存入表3的C列（同时填写A、B列为匹配的结构），没有匹配的存入表2的B列。匹配规则为：在“包含”的选项中，且不得含有“排除的词根”，“包含”是完整匹配（根据现有代码猜测），“排除”是部分匹配。

如果描述有不正确，请修正，需求确定后才开始编码。

感觉代码并不难，可能是楼主不喜欢多层循环比较，我取消使用正则表达式，改为InStr判断。

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

如果理解了，报错的时候点“调试”按钮，自然就知道什么原因，怎么修改。

发帖子给的示例数据不是实际问题的，自己必然要做一些简单的举一反三，要动动脑筋。如果希望别人完全帮你解决问题，是不是应该提供真实的数据。你看看报错的是不是这个语句：
If arrKey1(i, 1) = t Then
如果是，看看等号左右变量的值和类型，是不是一个数值一个文本，而且文本无法转换为数值，解决类型匹配修改语句为：
If Trim(arrKey1(i, 1)) = Trim(t) Then
当然，这样修改也不是万能的，当时单元格是内容公式错误（例如被0除、找不到等）时一样会报错，这时候的解决方法是先判断单元格数据类型，对 vbError 进行特殊判断。

老师不好意思，打扰你时间了，因我不懂，这个也是别个老师帮我弄的。真实数据还没弄完善，只有这小部份,为了快速筛选创建才来求老师看能帮忙实现不。不便之处请见谅。