11.png (46.86 KB, 下载次数: 0)
下载附件
2023-2-12 13:28 上传
想修改成这样的，可以筛选不需要的词根关健词
22.png (86.94 KB, 下载次数: 0)
下载附件
2023-2-12 13:28 上传
蓝奏云-关键词分词工具下载 https://wufeitao.lanzoub.com/i0QjZ0nbi1yd
Sub 快速分词()
Dim a, b, c, h, i, jj, k As Integer
Range("A3:A200000").Font.ColorIndex = 0 '以A3为起点，从左至右，从上至下，区域内的单元格字体颜色为黑色
Range("B3:IV200000").ClearContents '清空，从以B3为起点，从左至右，从上至下，区域内的单元格内容
a = [a200000].End(3).Row '获取A列从第3行开始统计总共有数据的行数，也就是关键词的总个数
b = [iv2].End(xlToLeft).Column '获取第二行，词根行的总个数
c = 0 '获取分组的关键词总个数
Cells(1, 1) = ""
For i = 3 To b
h = 0
k = 3
For jj = 3 To a
arr = Split(Cells(2, i), "+")
x = Int(UBound(arr) + 1)
If x > 4 Then
MsgBox "对不起，为减少计算占用内存程序暂时只支持最多4个词根的完全存在的组合，请检查词根是否有大于3个“+”", 48, "问题提示"
Exit Sub
End If
If x = 1 Then
If Cells(jj, 1) Like "*" & Cells(2, i) & "*" And Cells(jj, 1).Font.ColorIndex 15 Then
Cells(k, i) = Cells(jj, 1)
Range("A" & jj).Font.ColorIndex = 15
k = k + 1
c = c + 1
End If
ElseIf x > 1 Then
Select Case x
Case 2
If Cells(jj, 1) Like "*" & arr(0) & "*" And Cells(jj, 1) Like "*" & arr(1) & "*" And Cells(jj, 1).Font.ColorIndex 15 Then
Cells(k, i) = Cells(jj, 1)
Range("A" & jj).Font.ColorIndex = 15
k = k + 1
c = c + 1
End If
Case 3
If Cells(jj, 1) Like "*" & arr(0) & "*" And Cells(jj, 1) Like "*" & arr(1) & "*" And Cells(jj, 1) Like "*" & arr(2) & "*" And Cells(jj, 1).Font.ColorIndex 15 Then
Cells(k, i) = Cells(jj, 1)
Range("A" & jj).Font.ColorIndex = 15
k = k + 1
c = c + 1
End If
Case 4
If Cells(jj, 1) Like "*" & arr(0) & "*" And Cells(jj, 1) Like "*" & arr(1) & "*" And Cells(jj, 1) Like "*" & arr(2) & "*" And Cells(jj, 1) Like "*" & arr(3) & "*" And Cells(jj, 1).Font.ColorIndex 15 Then
Cells(k, i) = Cells(jj, 1)
Range("A" & jj).Font.ColorIndex = 15
k = k + 1
c = c + 1
End If
End Select
End If
Next jj
If k = 3 Then
l = "暂无"
Cells(h + 3, i) = l
Cells(h + 3, i).Font.ColorIndex = 5
End If
Next i
'统计分组个数
s = "待分关键词" & a - 2 & "个" & vbCrLf & "已成功分组" & c & "个" & vbCrLf & "未完成分组" & a - c - 2 & "个"
Range("C" & 1) = s
Call BB
End Sub
Sub XXX()
Dim a, b, c, h, i, j, k As Integer
Range("A3:A200000").Font.ColorIndex = 0 '以A3为起点，从左至右，从上至下，区域内的单元格字体颜色为黑色
Range("B3:IV200000").ClearContents '清空，从以B3为起点，从左至右，从上至下，区域内的单元格内容
a = [a200000].End(3).Row '获取A列从第3行开始统计总共有数据的行数，也就是关键词的总个数
b = [iv2].End(xlToLeft).Column '获取第二行，词根行的总个数
c = 0 '获取分组的关键词总个数
For i = 3 To b
h = 0
k = 3
For j = 3 To a
If Cells(j, 1) Like "*" & Cells(2, i) & "*" And Cells(j, 1).Font.ColorIndex 15 Then
Cells(k, i) = Cells(j, 1)
Range("A" & j).Font.ColorIndex = 15
k = k + 1
c = c + 1
End If
Next j
If k = 2 Then
l = "暂无"
Cells(h + 2, i) = l
Cells(h + 2, i).Font.ColorIndex = 5
' Else
' h = k - 1
' l = "共有" & (k - 2) & "个关键词"
' Cells(h + 2, i) = l
' Cells(h + 2, i).Font.ColorIndex = 3
End If
Next i
'统计分组个数
s = "待分关键词" & a - 2 & "个" & vbCrLf & "已成功分组" & c & "个" & vbCrLf & "未完成分组" & a - c - 2 & "个"
Range("C" & 1) = s
Call BB
End Sub
Sub BB() '作用是获取未分组的关键词，并显示到第二列
Dim a, i, k As Integer
a = [a200000].End(3).Row
k = 3
For i = 3 To a
If Range("A" & i).Font.ColorIndex 15 Then
Range("B" & k) = Range("A" & i)
k = k + 1
End If
Next i
End Sub
Sub 清空内容() '清空内容并还原颜色
a = [a200000].End(3).Row
Range("B3:IV200000").ClearContents
Range("A3:IV200000").Font.ColorIndex = 1
s = "待分关键词" & a - 2 & "个" & vbCrLf & "已成功分组 0 个" & vbCrLf & "未完成分组" & a - 2 & "个"
Range("C" & 1) = s
End Sub
Sub 清除()
i = Range("A1048576").End(xlUp).Row
Range("a3:a" & i).clear
End Sub
