| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 643 人关注过本帖
标题:先发一下吧~可能哪位大神路过呢
只看楼主 加入收藏
吴虾咪
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2023-2-12
结帖率:100%
收藏
已结贴  问题点数:20 回复次数:7 
先发一下吧~可能哪位大神路过呢
样式.rar (99.47 KB)


以下图解

图片附件: 游客没有浏览图片的权限,请 登录注册
2023-05-16 13:52
阳光上的桥
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:38
帖 子:129
专家分:772
注 册:2023-1-12
收藏
得分:14 
好像功能都已经实现,各按钮都可以动作,这是一个分享贴吗
2023-05-18 08:28
吴虾咪
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2023-2-12
收藏
得分:0 
回复 2楼 阳光上的桥
终于有人回复了,老师,归类功能可以,就是排除这个功能没有实显。老师,像这个可以实显吗,这啥结贴了。

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


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

2023-05-19 12:10
阳光上的桥
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:38
帖 子:129
专家分:772
注 册:2023-1-12
收藏
得分:0 
你的需求一个字都没有描述,请看发帖的图,看看我猜对没有:

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

如果描述有不正确,请修正,需求确定后才开始编码。
2023-05-19 14:47
阳光上的桥
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:38
帖 子:129
专家分:772
注 册:2023-1-12
收藏
得分:0 
感觉代码并不难,可能是楼主不喜欢多层循环比较,我取消使用正则表达式,改为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
2023-05-19 15:41
吴虾咪
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2023-2-12
收藏
得分:0 
回复 5楼 阳光上的桥
老师,意思是这样的。“包含”是完整匹配(根据现有代码猜测),“排除”是部分匹配。

就是关健词有包含词根的都算,除了排除的不包含在内。“包含”不是完整匹配的。

刚才试一下老师的,好像就是完整包含匹配.

然后我用数字来测看哪里还有的。就出现问题了,不知道什么回事。
数字.rar (38.68 KB)
2023-05-21 08:37
阳光上的桥
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:版主
威 望:38
帖 子:129
专家分:772
注 册:2023-1-12
收藏
得分:0 
没有好像不好像的,计算机一就是一,二就是二,请仔细阅读并理解下面的代码:

程序代码:
            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 进行特殊判断。
2023-05-22 08:38
吴虾咪
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2023-2-12
收藏
得分:0 
回复 7楼 阳光上的桥
教育.zip (72.08 KB)


老师不好意思,打扰你时间了,因我不懂,这个也是别个老师帮我弄的。真实数据还没弄完善,只有这小部份,为了快速筛选创建才来求老师看能帮忙实现不。不便之处请见谅。
2023-05-22 11:33
快速回复:先发一下吧~可能哪位大神路过呢
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.028882 second(s), 9 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved