哪个字（词）出现次数最多？

守柔

抽空做了一个VBA的，大家测试一下。有问题请及时交流。

以下代码供参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-1-25 08:32:33 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub WordsCount() Dim i As Range, aVar As Variable, aString As String, MyString As String '友情提示 MsgBox "受文档字数和可用内存以及WORD自身限制,您的操作可能会需要一段时间," & vbCrLf & _ "也许会出现可用内存不足的情况,您可能需要重启WORD以便接着下一次的工作!", vbOKOnly + vbExclamation, "Warnning" VarClear '清空文档变量 BkClear '清空书签 For Each i In Me.Words '词中循环 Me.UndoClear '清空撤消,以便留有足够内存 If i.Characters.Count > 1 Then '按中文习惯超过二个字或者两个字者组为词 '判断是否为中文字符 If Asc(i.Characters(1)) < -2050 And Asc(i.Characters(1)) > -20319 Then '如果已存在该书签(相当于第二次以上出现该词/字) If Me.Bookmarks.Exists(i.Text) = True Then On Error Resume Next '添加文档变量 Me.Variables.Add Name:=i.Text '设置错误陷阱 If Err.Number <> 0 Then Err.Clear '清除错误 '将次数累加写入 Me.Variables(i.Text).Value = Me.Variables(i.Text).Value + 1 Else '首次写入文档变量时,其初始值为2 Me.Variables(i.Text).Value = 2 End If Else '添加新书签 Me.Bookmarks.Add Name:=i.Text End If End If End If Next Application.ScreenUpdating = False '关闭屏幕更新 With Selection .EndKey unit:=wdStory '移到文档末尾 '作一个区分标记 .InsertAfter vbCrLf & "-----------------------二次以上（含二次）词数频次统计列表-----------------------" & vbCrLf .EndKey unit:=wdStory '移到文档末尾 For Each aVar In Me.Variables '在文档变量中循环 '插入文档中 aString = """" & aVar.Name & """出现频次:" & vbTab & aVar.Value & vbCrLf MyString = MyString & aString '文本累加写入内存变量中,以加速运行 Next .InsertAfter MyString MyString = "" '释放变量 '根据出现频次排序,以降序方式进行 .Sort FieldNumber:="域 1", SortFieldType:= _ wdSortFieldNumeric, SortOrder:=wdSortOrderDescending End With Me.UndoClear '清空撤消 VarClear '清空文档变量 BkClear '清空书签 Application.ScreenUpdating = True '恢复屏幕更新 End Sub '---------------------- Sub VarClear() Dim V As Variable For Each V In Me.Variables V.Delete '删除文档变量 Next End Sub '---------------------- Sub BkClear() Dim BK As Bookmark Me.UndoClear '清空撤消 For Each BK In Me.Bookmarks BK.Delete '删除书签 Me.UndoClear Next End Sub '----------------------
suPzIm49.zip (16.69 KB, 下载次数: 55)

2005-1-25 08:34 上传

点击文件名下载附件
哪个字（词）出现次数最多？

wan_shan

如果只是为了统计某个字（词）出现的次数，可以用“查找/替换”功能，比如查找“爱情”，替换成“金钱”，然后选择“全部替换”即可弹出对话框显示替换了多少个！然后用“撤销”功能恢复原貌。当然，也可以查找“爱情”，替换成“爱情”，同样可以显示出现的次数，还不用“撤销”。

守柔

以下是引用wan_shan在2005-1-25 9:15:00的发言： 如果只是为了统计某个字（词）出现的次数，可以用“查找/替换”功能，比如查找“爱情”，替换成“金钱”，然后选择“全部替换”即可弹出对话框显示替换了多少个！然后用“撤销”功能恢复原貌。当然，也可以查找“爱情”，替换成“爱情”，同样可以显示出现的次数，还不用“撤销”。

欢迎wan_shan

谢谢大哥，这个大伙儿都懂。

apolloh

学习了，以上偶全不懂。现在起来学，每天10贴！

守柔

在第十三楼的例子中，由于WORD中的书签的定义与引用消耗大量WORD内存，导致代码运行速度相当慢。为了进一步优化，先是想到了数组，但在WORD中使用数组后存在一个MATCH的问题，则需要调用EXCEL，还得使用两处错误陷阱，测试了一下，不理想，就否定了。然后，就有了以下的代码，与网友们分享之：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By 守柔(ShouRou)@ExcelHome 2005-1-26 5:38:36 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub WordsCountTwo() Dim i As Range, aVar As Variable, aString As String, MyString As String '友情提示 MsgBox "受文档字数和可用内存以及WORD自身限制,您的操作可能会需要一段时间," & vbCrLf & _ "也许会出现可用内存不足的情况,您可能需要重启WORD以便接着下一次的工作!", vbOKOnly + vbExclamation, "Warnning" For Each i In Me.Words '词中循环 If i.Characters.Count > 1 Then '按照中文习惯为二个以上为词组 '判断是否为中文字符 If Asc(i.Characters(1)) < -2050 And Asc(i.Characters(1)) > -20319 Then If MyString = "" Then GoTo GN '循环初始阶段跳至GX行标签 If InStr(MyString, i.Text & ",") = 0 Then GN: aString = i.Text & "," '加入","分隔符以便精确定位 MyString = MyString & aString Else On Error Resume Next '忽略错误 Me.Variables.Add Name:=i.Text '添加文档变量 If Err.Number <> 0 Then '设置错误陷阱 Err.Clear '清除错误 '将次数累加写入 Me.Variables(i.Text).Value = Me.Variables(i.Text).Value + 1 Else '首次写入文档变量时,其初始值为2 Me.Variables(i.Text).Value = 2 End If End If End If End If Next aString = "": MyString = "" '重新初始化变量 Application.ScreenUpdating = False '关闭屏幕更新 With Selection .EndKey unit:=wdStory '移到文档末尾 '作一个区分标记 .InsertAfter vbCrLf & "------------------------------------词数频次统计列表------------------------------------" & vbCrLf .EndKey unit:=wdStory '移到文档末尾 For Each aVar In Me.Variables '在文档变量中循环 '插入文档中 aString = """" & aVar.Name & """出现频次:" & vbTab & aVar.Value & vbCrLf MyString = MyString & aString '文本累加写入内存变量中,以加速运行 Next .InsertAfter MyString '根据出现频次排序 .Sort FieldNumber:="域 1", SortFieldType:= _ wdSortFieldNumeric, SortOrder:=wdSortOrderDescending End With VarClear '清空文档变量 Me.UndoClear '清空撤消 Application.ScreenUpdating = True '恢复屏幕更新 End Sub '---------------------- Sub VarClear() Dim V As Variable For Each V In Me.Variables V.Delete '删除文档变量 Next End Sub '----------------------

实测运行速度较之十三楼的至少快一倍，且无需反复清空撤消，代码更简洁明了。

一意孤行

以下是引用cxffxc在2004-4-8 21:07:00的发言：
2楼的宏运行结果极不理想，一个很小的文档，都有很多字符没有统计到。 3楼的方法不能达到要求。 盼高手解答，谢谢！

不知道很多字符是那些字符？ 因为有AscB(AChar) > 128 限制，所以没有统计ASCII 字符 如果你需要统计这部分内容，可以把这个if判断去掉。

一意孤行

以前编的一个统计 中文文档中各个字出现的频率的程序。 Sub 字符频率()
Dim AChar, tChar As String
Const MaxChar = 3000
Dim Chars(MaxChar) As String
Dim Freq(MaxChar) As Integer
Dim CharNum As Integer
Dim Found As Boolean
Dim i, j, k, Temp As Integer
CharNum = 0
Found = False
For Each aCharacter In ActiveDocument.Characters
AChar = aCharacter
If AscB(AChar) > 128 Then
For i = 1 To CharNum
If Chars(i) = AChar Then
Freq(i) = Freq(i) + 1
Found = True
Exit For
End If
Next i
If Not Found Then
CharNum = CharNum + 1
Chars(CharNum) = AChar
Freq(CharNum) = 1
End If
Found = False
End If
Next aCharacter
For i = 1 To CharNum - 1
k = i
For j = i + 1 To CharNum
If Freq(j) > Freq(k) Then k = j
Next j
If k <> i Then
tChar = Chars(i)
Chars(i) = Chars(k)
Chars(k) = tChar
Temp = Freq(i)
Freq(i) = Freq(k)
Freq(k) = Temp
End If
Next i
tmpName = ActiveDocument.AttachedTemplate.FullName
Documents.Add Template:=tmpName, NewTemplate:=False
With Selection
.TypeText "文档中共有" & CharNum & "个不同字符" & vbCrLf
.TypeText "字符名称" & vbTab & "出现的频率" & vbCrLf
For i = 1 To CharNum
.TypeText Text:=Chars(i) & vbTab & Freq(i) & vbCrLf
Next i
End With End Sub

lawyer_gb

感谢分享。我已经用这个函数统计出  四中全会公报中 法 字出现最多237个。

praijna

lawyer_gb 发表于 2014-10-24 15:24
感谢分享。我已经用这个函数统计出  四中全会公报中 法 字出现最多237个。

老师，国庆节快乐！
繁体古文中多有汉字不能被统计，不知道如何？

y294945022

wan_shan 发表于 2005-1-25 09:15
如果只是为了统计某个字（词）出现的次数，可以用“查找/替换”功能，比如查找“爱情”，替换成“金钱”， ...

这个方法不错。