[求助]如何不重复地统计字数

pumasarel

求教：word中有时要用到字数统计功能，但我想不重复的统计，这里我已在网上找到高手编的vba运行码，但它是统计中文的，我试过，管用，但我想统计英文，自己又是个菜鸟， 一点不懂，求懂的朋友把它改一下以能用于不重复地统计英文字数，谢了！

Sub 不重复字符知多少()
Dim AllText As String, B As String
Dim i As Long, StartTime As Single
Dim OnlyText As String
StartTime = Timer
AllText = ActiveDocument.Content.Text
For i = 1 To Len(AllText)
B = Mid(AllText, i, 1)
If B Like "[一-龥]" Then '如果属于汉字字符(CJK统一汉字字符集)
If OnlyText = "" Then
OnlyText = B '为变量赋初值
ElseIf VBA.InStr(OnlyText, B) = 0 Then
'如果在OnlyText变量中,没有出现过的字符,则加入该变量字符集中
OnlyText = OnlyText & B
End If
End If
Next
MsgBox Len(OnlyText), vbOKOnly, Timer - StartTime
End Sub

帖子出处：http://club.excelhome.net/viewthread.php?tid=118832

konggs

英文字数?何数？

是指单词？

A B 也算单词吗？

写了一个简单的。

Sub 知多少()

Dim StartTime As Single
Dim newdir As Collection
Dim arr
StartTime = Timer
Set newdir = New Collection

On Error Resume Next
For Each arr In ActiveDocument.Words
    arr = Trim(arr)
    If arr Like "[a-zA-Z]*" Or arr Like "[a-zA-Z]*'[a-zA-Z]" Then '如果属于汉字字符(CJK统一汉字字符集)
       newdir.Add arr, arr
    End If
Next

MsgBox newdir.Count, vbOKOnly, Timer - StartTime
End Sub

守柔

QUOTE:

以下是引用konggs在2007-1-29 19:00:45的发言：

英文字数?何数？

是指单词？

A B 也算单词吗？

写了一个简单的。

Sub 知多少()

Dim StartTime As Single
Dim newdir As Collection
Dim arr
StartTime = Timer
Set newdir = New Collection

On Error Resume Next
For Each arr In ActiveDocument.Words
    arr = Trim(arr)
    If arr Like "[a-zA-Z]*" Or arr Like "[a-zA-Z]*'[a-zA-Z]" Then '如果属于汉字字符(CJK统一汉字字符集)
       newdir.Add arr, arr
    End If
Next

MsgBox newdir.Count, vbOKOnly, Timer - StartTime
End Sub

孔兄，我另用差不多一法，应该更快一些，你试一下。

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-1-30 6:38:04
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0149^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Option Compare Text
Sub EnglishWordsCount()
    Dim myString As String
    Dim myArray() As String, aArray As Variant, StartTime As Single
    Dim myCollection As New Collection, EndTime As Single
    On Error Resume Next
    StartTime = Timer
    myString = ActiveDocument.Content.Text
    myString = VBA.Replace(myString, Chr(13), " ")
    myArray = VBA.Split(myString, " ")
    For Each aArray In myArray
        If aArray Like "[a-z]*" Then
            myCollection.Add aArray, aArray
        End If
    Next
    EndTime = Timer
    MsgBox "文档中不重复的单词数有" & myCollection.Count, vbInformation, "用时:" & EndTime - StartTime
End Sub
'----------------------

我只是说运算方法，如果精确的话，你的程序精确（比如在我这个代码中，可以加上把手动换行符也替换为空格等）。

konggs

谢谢老大。我也曾想到。但是当在中汉文混合在一起就不行 了，所以，我把word交给微软来判断。老大的在内在做，速度肯定快些。

pumasarel

konggs朋友的办法我已试过，管用，看来真是知之为知之呵。下面一位朋友的也试了一下，与kongss的统计结果有出入，不知是怎么回事，我用来统计的样本是林语堂“生活的艺术”英文版，分别是12000多字和16000多字，我用少量文本作试验，得knoggs的结果是附合的，所以采用了它。不知怎么回事，底下朋友的有时还会对着一段文字得出0的结果，不知是不是我操作不当。

下面我还有一个问题，英文中专有名词特别多，人名地名等等，它都要算一个词，但实际上我们并不把它当一个词来掌握。但读有的文章，如报刊，这个因素几乎是不可忽视的，否则得出的“词汇量”不免是个虚的。现在我手头就有个文本，新东方印建坤的阅读100篇，得词汇量10566，我怕这个量就是虚的，因这个阅读采用了很多报刊文章，内多人地名之类。能否进一步改进一下，能把专有名词区分开来？想全部区分开来我知道有一定难度。但至少利用首字母大写特点可以区分出一部分，除句首位置外的所有专有名词。两位高手想必会有更高的招儿。怎么样，还有兴趣接着改进一下吗？

致以崇高的期望！等着了！

pumasarel

我刚又统计了新概念老版，得四册词汇量8067词，但老版词量实际只有5714，这个出入是相当大了,，以至统计出的结果没有什么实际价值。估计是各种非单词因素的干扰。不排除文档合并操作过程中由于文本误接等所产生的误差，但不至于如此之巨。我对第四册的合并文档进行了粗略的较改，前后出入也只有几十个词。

[此贴子已经被作者于2007-2-1 17:58:57编辑过]

konggs

你好。你所指的“下面的一位朋友”是我们论坛的首席版主也是我们的老师——守柔——中国大陆唯一的Word MVP，而且是二次获得。

关键是你的要求比较模糊。若有一个海量的英文单词数据库，与这个数据库比较，则比较准确，但这个从何而来呢？用首行字母不好判断吧？专有名词也是，有数据库才能比较。

pumasarel

不好意思了，非常不好意思。向守柔老师致谦。此论坛我是初来乍到，唐突夫子，做检讨。想必是我操作失误。还望守柔老师不以为嫌，乐意解答我的问题。向kongss版主致敬！

关于数据库的话，这个比较麻烦了，关健是面对一个任意文本，并不知道它是否含有超出此数据库的词，这个库就要足够的大，但大到何种程度，界限又是模糊的，找都没法找。并且英语有动名形副的变化形式，再大的数据库也无能为力---大概是这样吧，----如果是，事实上这一途怕就是走不通。

我想我的要求还是清晰的，就是找出那些通用单词。你现在这个程序已经很有效，能区分出一个个貌似单词的东东，这些东东至少80%以上它就是单词，它比数据库有天然的优势，即开放性，不必界定一个个的具体的词。它已经相当一个大到无限的“库”。现在只要改进一下即可，在这个基础上加几行，挑出不符合条件的假词。

1，全挑出上面讲过了，有困难。现在的思路是挑出一部分算一部分，在可能的限度内减少误差。利用文内（句首外，即句号之后的位置）专有名词首字母大写的特征来筛选至少在理论上应当是可行的。这些词当然并非都是专有名词，但此误差可忽略，或就把它忽略。关健是技术上有困难吗？这个我就不知道了。

2，不光是上面的问题，还要加一个问题。昨天忘写了。即动形副名-词的变化问题，这个因素在重复统计上应当起着相当大的干扰作用。从新概念的统计结果看出，这两个因素（不知还有没有其它的我没考虑到）加起来使统计结果的误差达到了总量的1/4强。还是遵循“挑一部分算一部分在可能限度内减误差”的原则。当然也要考虑麻烦的问题，这个因素要考虑多少就取决于编写者了，呵呵。至少规则变化的那些在理论上是可以挑出的。即：某一词如只比其它部分某一个已计数的词在最后位置加了ed,er,est,则将其不计数。名词要敏感一些，因只比前面某个词多加一个s的词它可能是另一个词的可能性要大些。这里实际是一个误差概率的比较取舍问题。统一一下，4项都算吧，即比其它部分某一个已计数的词在最后位置加了ed,er,est,或s则将其不计数。另名词的不规则变化我觉得可以考虑进去，即加es的情况，因它前面只有5种情况：s,sh,ch,x,o。

其实这个问题如果要在理论上深究下去，还是很有意思的。如可以结合构词知识设定什么情况下加ed,er等，当然这也相当麻烦。这里我个人就不提要求了。

加几行吧，哈，麻烦了。

个人觉得可以用这个思路编一个实用软件，这个软件由两部分构成，一个就是现在已有的部分，叫粗略计数，它测出的是词汇量上限，快。另一个就是现在讨论的要改进的部分，测出的是---要想说测出的是下限可能还要加上一些条件。这个慢一些。两者结合即可估定一个文档的词汇量。我就serve as its first user吧。ha

[此贴子已经被作者于2007-2-1 18:00:18编辑过]

pumasarel

不好意思，惭愧之极。刚才突然一个念头跳上心头，把我引用来的帖子重看了一下，才知我引来的那个帖子作者就是两位老大，我还在那么那么说，这都叫什么事！自己打一个嘴巴！其实引帖时它就出自这个论坛我已注意到了（网上海捞搜到的帖，并非在这里找到），不遑细看，随手就那么一引，更要命的是在回贴中还有就那么的一说，沉痛！

konggs版主在回贴中这一层都没有挑明，吾而今知什么是深藏若虚了。

konggs

没关系的，我们都是抱着学习的心理的。

Sub 知多少()

Dim StartTime As Single
Dim newdir As Collection
Dim arr
Dim StrPrevious As String
StartTime = Timer
Set newdir = New Collection
Dim Testlong As Long
On Error Resume Next
For Each arr In ActiveDocument.Words
    arr = Trim(arr)
    If arr Like "[a-zA-Z]*" Or arr Like "[a-zA-Z]*'[a-zA-Z]" Then '如果属于汉字字符(CJK统一汉字字符集)
        If StrPrevious <> "." And Mid(arr, 1, 1) Like "[A-Z]" Then
          '即你第一个要求，即不算
        ElseIf Right(arr, 2) = "ed" Or Right(arr, 2) = "er" Then
             arr = Left(arr, Len(arr) - 2)
        ElseIf Right(arr, 3) = "est" Then
            arr = Left(arr, Len(arr) - 3)
        '多加几个elseif试试
        Else
            newdir.Add arr, arr
        End If
    End If
    StrPrevious = arr
Next
       
MsgBox newdir.Count, vbOKOnly, Timer - StartTime
End Sub