统计得出出现次数最多的词语，虚心求解

eernnip

虚心求解

样本.rar (2.41 KB, 下载次数: 43)

2015-2-6 23:39 上传

点击文件名下载附件

Zamyi

1. Sub test()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. r = Range("a1").CurrentRegion
   
4. ReDim a(1 To UBound(r, 2), 1 To UBound(r))
   
5. For i = 2 To UBound(r)
   
6.   For j = 3 To UBound(r, 2)
   
7.     If r(i, j) <> "" Then
   
8.       If d.Exists(r(i, j)) Then
   
9.         n = Val(d(r(i, j)))
   
10.         d(r(i, j)) = Replace(d(r(i, j)), n, n + 1, , 1) & vbTab & r(i, 2)
    
11.         Else
    
12.         d(r(i, j)) = 1 & vbTab & r(i, j) & vbTab & r(i, 2)
    
13.       End If
    
14.     End If
    
15.   Next
    
16. Next
    
17. With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
18.   .SetText Join(d.items, vbNewLine)
    
19.   .PutInClipboard
    
20.   Sheet1.Paste [a17]
    
21. End With
    
22. Range("a17").CurrentRegion.Offset(1).Sort [a17], 2
    
23. End Sub
    

复制代码

hlly888

请看附件                     

hlly888

样 本.zip (14.79 KB, 下载次数: 108)

2015-2-7 10:10 上传

点击文件名下载附件

mmwwdd

这个用正则表达式最好

FLY-VITAS

不知道楼主问题解决了没，自己动手写了一个，希望对你有帮助

eernnip

hlly888 发表于 2015-2-7 10:10

感谢大神><

eernnip

FLY-VITAS 发表于 2015-2-7 14:37
不知道楼主问题解决了没，自己动手写了一个，希望对你有帮助

谢谢你的答案，已解决

bluexuemei

1. Sub test()
   
2. '需要安装ACTIVERUBY ，下载地址 http://www.artonx.org/data/asr/Ruby-2.1.1.msi
   
3. Set ojs = CreateObject("scriptcontrol"): ojs.Language = "rubyscript"
   
4. ojs.eval ("def aa(a);$a=a;end")
   
5. y = ojs.Run("aa", Range("b2:j" & [b2].End(4).Row).Value)
   
6. y = ojs.eval("h=Hash.new{[]};$a.each{|x|x[1..-1].each{|k|if k!=nil;h[k]<<=x[0];end}};h.sort_by{|k,v|-v.size}.map{|k,v|[v.size,k,*v]}")
   
7. [a17].Resize(UBound(y) + 1, UBound(y, 2) + 1) = y
   
8. Set ojs = Nothing
   
9. 'Stop
   
10. End Sub

复制代码

eernnip

Zamyi 发表于 2015-2-7 09:17

大神，根据你的方法，已解决