[已解决]这个也能用字典统计吗？

ww0000

Book1.rar (8.31 KB, 下载次数: 19)

2017-4-13 12:17 上传

点击文件名下载附件

要求已在附件中，谢谢

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-4-14 14:04

注意，结果是错的，错误原因有两个：
1、相同keyword不同意思的项目会归成一类；
2、一个字符串内出现两个keyword，所以后续处理结果会覆盖前次处理结果。
代码本身完全按照keyword规则设定，没有问题。

1. Sub aaa()
   
2. Dim arr, brr, i&, j&, k&, s$, r
   
3. arr = Range("a1:b" & [a65536].End(3).Row)
   
4. ReDim brr(1 To UBound(arr) - 1, 1 To 2)
   
5. For i = 2 To UBound(arr) - 1
   
6.   If arr(i, 2) <> "" Then
   
7.     r = r + 1
   
8.     brr(r, 1) = arr(i, 2)
   
9.     brr(r, 2) = 1
   
10.     For k = i + 1 To UBound(arr)
    
11.       s = arr(k, 2)
    
12.       For j = 1 To Len(s) - 1
    
13.         If InStr(brr(r, 1), Mid(s, j, 2)) Then
    
14.           If Len(s) > Len(brr(r, 1)) Then brr(r, 1) = s
    
15.           brr(r, 2) = brr(r, 2) + 1
    
16.           arr(k, 2) = ""
    
17.           Exit For
    
18.         End If
    
19.       Next j
    
20.     Next k
    
21.   End If
    
22. Next i
    
23. [g2].Resize(r, 2) = brr
    
24. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

这个要求的话就没有字典的用武之地了，数组循环就可以，
当然硬要用字典做也行，但已失去字典的优势。

另，“故意”两字出现的次数很多，内容都不相同，
按照你的keyword设定是需要合并的，实际上不应该合并，
你不应该考虑下规则设定的正确性吗？

ww0000

大灰狼1976 发表于 2017-4-13 14:44
这个要求的话就没有字典的用武之地了，数组循环就可以，
当然硬要用字典做也行，但已失去字典的优势。

不好意思，“故意”两字重复的是不能合并统计，可以设定排除指定字符，另外能用“数组循环”解决也可，谢谢

大灰狼1976

我的意思是你的原数据可能不止这些，规则制定时一定要严谨，不然做出来你套用时也会有问题。
像“危险”两个字也是出现在不同的内容之中，就不一一列举了，可能你对数据的观察还没有我用心。
希望能再次认真核对一次后再提要求。

ww0000

大灰狼1976 发表于 2017-4-13 15:32
我的意思是你的原数据可能不止这些，规则制定时一定要严谨，不然做出来你套用时也会有问题。
像“危险”两 ...

排除你说的特殊情况，能用VBA达到我的要求吗？我的原数据比这个会简单

大灰狼1976

如果你能排除所有特殊情况，当然可以做，数组循环加上字符串内每两个连续字符的遍历，再用instr()判断，
最后用LEN()比较字符串长度，将长字符串替换掉结果数组的短字符串就行了。有时间我可以做一下，先不管
你数据的问题了，只按照你的keyword规则来做。

ww0000

大灰狼1976 发表于 2017-4-13 17:43
如果你能排除所有特殊情况，当然可以做，数组循环加上字符串内每两个连续字符的遍历，再用instr()判断，
...

好的，先谢过了！

大灰狼1976

注意，结果是错的，错误原因有两个：
1、相同keyword不同意思的项目会归成一类；
2、一个字符串内出现两个keyword，所以后续处理结果会覆盖前次处理结果。
代码本身完全按照keyword规则设定，没有问题。

1. Sub aaa()
   
2. Dim arr, brr, i&, j&, k&, s$, r
   
3. arr = Range("a1:b" & [a65536].End(3).Row)
   
4. ReDim brr(1 To UBound(arr) - 1, 1 To 2)
   
5. For i = 2 To UBound(arr) - 1
   
6.   If arr(i, 2) <> "" Then
   
7.     r = r + 1
   
8.     brr(r, 1) = arr(i, 2)
   
9.     brr(r, 2) = 1
   
10.     For k = i + 1 To UBound(arr)
    
11.       s = arr(k, 2)
    
12.       For j = 1 To Len(s) - 1
    
13.         If InStr(brr(r, 1), Mid(s, j, 2)) Then
    
14.           If Len(s) > Len(brr(r, 1)) Then brr(r, 1) = s
    
15.           brr(r, 2) = brr(r, 2) + 1
    
16.           arr(k, 2) = ""
    
17.           Exit For
    
18.         End If
    
19.       Next j
    
20.     Next k
    
21.   End If
    
22. Next i
    
23. [g2].Resize(r, 2) = brr
    
24. End Sub

复制代码

ww0000

大灰狼1976 发表于 2017-4-14 14:04
注意，结果是错的，错误原因有两个：
1、相同keyword不同意思的项目会归成一类；
2、一个字符串内出现两 ...

基本是这个意思，结果不对是因为我附件中的源数据有问题，谢谢了！

ww0000

大灰狼1976 发表于 2017-4-13 14:44
这个要求的话就没有字典的用武之地了，数组循环就可以，
当然硬要用字典做也行，但已失去字典的优势。

http://www.excelpx.com/thread-429354-1-1.html
这个也能帮我看看吗？