|
前时有本论坛网友和officefans论坛网友问及中文文档中字词数出现频次的统计问题，今天抽空对原有代码进行了完善和强化了操作对话功能，以满足不同用户的需要。并以原创为主题贴，以利今后搜索与查找。 以下代码供参考： '* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By 守柔(ShouRou)@ExcelHome 2005-2-3 5:50:25
'仅测试于System: Windows NT Word: 10.0 Language: 2052
'^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Sub WordsCountThree()
Dim i As Range, aVar As Variable, aString As String, MyString As String, BS As String
On Error Resume Next
'友情提示
MsgBox "受文档字数和可用内存以及WORD自身限制,您的操作可能会需要一段时间!", _
vbOKOnly + vbExclamation, "Warnning"
Select Case MsgBox("按YES统计字的出现频次,按NO统计词的出现频次,按CANCEL统计字与词!", _
vbYesNoCancel + vbInformation + vbDefaultButton2)
Case vbYes
BS = "字数频次统计列表"
For Each i In Me.Characters '字中循环
If Asc(i) < -2050 And Asc(i) > -20319 Then
If MyString = "" Then GoTo GNY
If InStr(MyString, i.Text & ",") = 0 Then
GNY: 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
Next
Case vbNo
BS = "词数频次统计列表"
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 GNN '循环初始阶段跳至GX行标签
If InStr(MyString, i.Text & ",") = 0 Then
GNN: 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
Case vbCancel
BS = "字词数频次统计列表"
For Each i In Me.Words '词中循环
'判断是否为中文字符
If Asc(i.Characters(1)) < -2050 And Asc(i.Characters(1)) > -20319 Then
If MyString = "" Then GoTo GNC '循环初始阶段跳至GX行标签
If InStr(MyString, i.Text & ",") = 0 Then
GNC: 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
Next
End Select
aString = "": MyString = "" '重新初始化变量
Application.ScreenUpdating = False '关闭屏幕更新
With Selection
.EndKey unit:=wdStory '移到文档末尾
'作一个区分标记
.InsertAfter vbCrLf & "------------------------------------" & BS & " ------------------------------------" & 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
'----------------------
g5AWZI01.rar
(13.25 KB, 下载次数: 391)
[此贴子已经被konggs于2007-3-5 17:22:00编辑过] | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-2-3 05:53
楼主
![[原创并分享]中文文档字词数频次统计](https://files-c.excelhome.net/forum/dvbbs/2005-2/20052355438915.bmp "[原创并分享]中文文档字词数频次统计")
发表于 2007-3-5 16:43
