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

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 = 1 To UBound(Arr)
    
18.                 If InStr(Arr(m, 1), Ary(i)) And m <> k And Len(Ary(i)) > 1 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
    

复制代码

EJR

感谢一念大师再次指导。
但还有两点美中不足：
1、一些不重复的单元格也被标记了；
2、标记的组数不是连续的数字。例如：1（3个）、2（4个）、5（2个）……应该是1（3个）、2（4个）、3（2个）……或者应该是1（3个）、4（4个）、8（2个）……

[ 本帖最后由 EJR 于 2010-6-30 12:50 编辑 ]

alzeng

1. 
   
2. Sub Tag()
   
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 = 1 To UBound(Arr)
    
18.                 If InStr(Arr(m, 1), Ary(i)) And m <> k And Len(Ary(i)) > 1 And Len(Arr(m, 2)) = 0 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 于 2010-6-30 14:12 编辑 ]

alzeng

有必要的说明：
1. 类似 喜欢 和 喜欢冒险 ，很明显不是一个意思，但因为后者包含前者，所以算同一分类。

2.有多重包容关系的词汇，未重复标注：

EJR

标记的组数不是连续的数字。
例如：1（3个）、2（4个）、5（2个）……应该是1（3个）、2（4个）、3（2个）……或者应该是1（3个）、4（4个）、8（2个）……

[ 本帖最后由 EJR 于 2010-6-30 14:28 编辑 ]

alzeng

这个要求你可以增加一列（比如在H列），输入公式下拉：
H3=COUNTIF(G:G,G3)

EJR

多谢一念大师反复指导！