如何用VBA对问题进行关键字匹配分类?

lmy7165

需要对1列数据进行问题分类处理,人工处理太慢,1.需要建查找到的关键字返回,2.需要对返回的关键字进行类别匹配;3.关键字约300个;4.数据量约10W 1.zip (21.43 KB, 下载次数: 173)

2021-1-10 23:14 上传

点击文件名下载附件
附件

lmy7165

坐等大佬~~

XUEJUNXI

您看一下是不是这个样子，查找到的关键字标识红色的话，运行有点慢。

zpy2

http://club.excelhome.net/forum.php?mod=viewthread&tid=1570323&mobile=2&_dsign=95971289

lmy7165

XUEJUNXI 发表于 2021-1-11 08:12
您看一下是不是这个样子，查找到的关键字标识红色的话，运行有点慢。

谢谢大佬,有效,慢点没事,本身数据量就庞大~~~~~

qlmgu

XUEJUNXI 发表于 2021-1-11 08:12
您看一下是不是这个样子，查找到的关键字标识红色的话，运行有点慢。

XUEJUNXI老师您的程序非常好用。如果对同一段文本能同时满足多个相关的关键词就更好了，例如，破碎，破损，坏了，不耐用等，在我的例子里都属于质量问题。谢谢您了。

qlmgu

lmy7165您好。非常感谢您提出的问题，因为我也有类似需求。现在有了各位老师的程序，关键问题反而出现在如何对关键词进行分类了。我有上千关键词需要分类处理，您有什么好经验呢。冒昧打扰，请包涵。

ggmmlol

qlmgu 发表于 2021-1-12 10:42
XUEJUNXI老师您的程序非常好用。如果对同一段文本能同时满足多个相关的关键词就更好了，例如，破碎，破损 ...

以下代码，对每一项分别列出其所包含的不重复的关键字，及其分类（也去掉重复分类）。

Sub 识别()
    Dim jg()
    Sheet1.Range("a:a").Font.Color = vbBlack
    Sheet1.Range("b2", Sheet1.Range("c" & Range("a2").End(xlDown).Row)).ClearContents
    arr = Sheet2.Range("b3", Sheet2.Range("c3").End(xlDown))
    brr = Sheet1.Range("a2", Sheet1.Range("a2").End(xlDown))
    pat = "(" & Join(Application.Transpose(Application.Index(arr, 0, 2)), "|") & ")(?![\d\D]*\1)"
    ReDim jg(1 To UBound(brr), 1 To 2)
    Set reg = CreateObject("vbscript.regexp")
    With reg
        .Pattern = pat
        .Global = True
    End With
    Set dic = CreateObject("scripting.dictionary")
    For j = 1 To UBound(arr)
        dic(arr(j, 2)) = arr(j, 1)
    Next
    For i = 1 To UBound(brr)
        Set dic0 = CreateObject("scripting.dictionary")
        For Each ma In reg.Execute(brr(i, 1))
            jg(i, 1) = jg(i, 1) & "," & ma.Value
            s = dic(ma.Value)
            If Not dic0.exists(s) Then dic0(s) = "": jg(i, 2) = jg(i, 2) & "," & s
            Sheet1.Range("a" & i + 1).Characters(ma.firstindex + 1, ma.Length).Font.Color = vbRed
        Next
        jg(i, 1) = Mid(jg(i, 1), 2)
        jg(i, 2) = Mid(jg(i, 2), 2)
    Next
    Sheet1.Range("b2").Resize(UBound(brr), 2) = jg
End Sub

XUEJUNXI

在吗？开始以为只要匹配一种就行。

wanghongfei

1. Sub sasw()
   
2. arr = Sheets(1).[a1].CurrentRegion
   
3. brr = Sheets(2).[b2].CurrentRegion
   
4. ReDim crr(1 To UBound(arr), 1 To 100)
   
5. 
   
6. For x = 2 To UBound(arr)
   
7.     k = 1: p = 2: m = 1: n = 1
   
8.     For i = 2 To UBound(brr)
   
9.         If InStr(arr(x, 1), brr(i, 2)) Then
   
10.         crr(1, k) = "分类" & m
    
11.         crr(1, p) = "关键词" & n
    
12.         crr(x, k) = brr(i, 1)
    
13.         crr(x, p) = brr(i, 2)
    
14.         k = k + 2
    
15.         p = p + 2
    
16.         m = m + 1
    
17.         n = n + 1
    
18.         End If
    
19.     Next
    
20. Next
    
21. Sheets(1).[b1].Resize(UBound(arr), 100) = crr
    
22. End Sub

复制代码

把所有关键词和分类给列在后面了