感谢figfig，但不太准确：能解释一下代码及思路吗？

EJR

请热心高手帮我给孩子做个英语单词分类程序。
标注相同解释的单词（只要单元格中有连续的两个字相同的词就用相同数字表示）

[ 本帖最后由 EJR 于 2010-6-29 06:59 编辑 ]

youliqi

不明确何为“单元格中有连续的两个字相同的词”

EJR

谢谢楼上朋友，我用红色标记了。
比如：F7中有：adj 英明的；明智的；聪明的，F16中有：adj.欢快的, 聪明的, 伶俐的。
都有共同的“聪明”二字，就视为相同，就在G列中标注相同的数字：2。
但如果不连续例如另一单元格中的：失聪，光明。则不能视为相同，不能标注2。

EJR

哪位帮忙啊，先谢谢了。

figfig

Sub kkk()

'须安装ACTIVERUBY.才能运行
'下载地址  http://www.artonx.org/data/asr/ActiveRuby.msi
Set x = CreateObject("scriptcontrol")
x.Language = "rubyscript"
y = x.eval("def aa aa;@aa=aa;1;end")
x.Run "aa", Sheet12.UsedRange.Value
y = x.eval("$KCODE='n';h1,h2={},{};arr=@aa[2..-1].map{|x| x[5]};brr=arr.join('-').gsub(/\w+|\s+|的|＆|（.*?）|《.*?》|\./,'');crr=brr.split(/\-|,|；|，/);crr.each{|x|  if h1.key?(x);h2[x]=h2.keys.count;end;h1[x]=0;};drr=[];arr.each{|x| ll='';h2.each_pair{|k,v| ll=v if x.include?(k)};drr<<ll;};drr;")
Sheet12.[g3:g8888] = Empty
Sheet12.[g3].Resize(UBound(y) + 1) = Application.Transpose(y)

End Sub

EJR

高！！！谢谢了！

不太准确，请看附件。能完美一下吗？

恳请：
能解释一下各重要代码吗？
Sheet12是什么啊？

[ 本帖最后由 EJR 于 2010-6-29 07:07 编辑 ]

alzeng

1. 
   
2. Sub GetTag()
   
3.     Dim Oj As Object, Str$, tag%
   
4.     Dim Arr, Ary, k%, i%, m%
   
5. 
   
6.     [G3:G65536].ClearContents
   
7.     Arr = Range("F3", [F65536].End(3)(1, 2))
   
8.     Str = Join(Application.Transpose(Application.Index(Arr, , 1)))
   
9.     Set Oj = CreateObject("ScriptControl"): Oj.Language = "JScript"
   
10.     Oj.eval "function getstr(str){return str.replace(/的/g,'').match(/[一-龥]+/g,'')}"
    
11. 
    
12.     For k = 1 To UBound(Arr)
    
13.         If Len(Arr(k, 2)) Then GoTo 1
    
14.         Ary = Split(Oj.codeobject.getstr(Arr(k, 1)), ",")
    
15.         For i = 0 To UBound(Ary)
    
16.             If InStr(Replace(Str, Arr(k, 1), ""), Ary(i)) Then tag = tag + 1
    
17.             For m = k To UBound(Arr)
    
18.                 If InStr(Arr(m, 1), Ary(i)) And m <> k Then Arr(m, 2) = tag: Arr(k, 2) = tag
    
19.             Next
    
20.         Next
    
21. 1
    
22.     Next
    
23. 
    
24.     [G3].Resize(k - 1) = Application.Index(Arr, , 2)
    
25. End Sub
    

复制代码

alzeng

单词标注.rar (110.81 KB, 下载次数: 18)

2010-6-29 08:53 上传

点击文件名下载附件

EJR

感谢一念大师赐教！仍然不太准确，不知是哪里的问题？

figfig

Sub kkk()

'须安装ACTIVERUBY.才能运行
'下载地址  http://www.artonx.org/data/asr/ActiveRuby.msi
Set x = CreateObject("scriptcontrol")
x.Language = "rubyscript"
y = x.eval("def aa aa;@aa=aa;1;end")
x.Run "aa", Sheet12.UsedRange.Value
y = x.eval("$KCODE='N';h1,h2={},{};arr=@aa[2..-1].map{|x| x[5]};brr=arr.join('-').gsub(/\w+|\s+|的|＆|（.*?）|《.*?》|\./,'');crr=brr.split(/\-|,|；|，/);crr.each{|x|  if h1.key?(x) && x.size>2;h2[x]=h2.keys.count+1;end;h1[x]=0 if x.size>2;};drr=[];arr.each{|x| ll='';h2.each_pair{|k,v|  if x.include?(k);ll=v.to_s+' '+ll;end;};drr<<ll;};drr;")


Sheet12.[g3:g8888] = Empty
Sheet12.[g3].Resize(UBound(y) + 1) = Application.Transpose(y)

End Sub