Word文档的中文字词频统计

sylun · 发表于 2012-3-10 14:15

本帖最后由 sylun 于 2012-6-13 18:22 编辑

统计中文字词频的相关帖子已有不少，昨晚用words集合对象提取中文词语时发现提取结果有时出现异常，原因主要是语法和拼写不规范所致，具体来说主要是汉字后面带半角空格或不间断空格，也有引号的问题。经过滤，异常现象有效避免。现将代码放上，也许还有其他异常情况，各位如有兴趣请测试测试，以便改进。

Sub ChineseCharCounting()
'统计汉字的字词频，并按降序排序
'中文词语的判断与Word的词典关联
Dim a As Byte
Dim n As Long
Dim filetext As String
Dim d
Dim Wd As Range
Dim W As Range
Dim b
Dim c() As String
Dim i As Long
Dim temp As String
Dim st As Single
a = MsgBox("词频统计请按“是”，字频统计请按“否”", vbYesNo, "中文字词频统计")
st = Timer
n = ActiveDocument.Content.ComputeStatistics(wdStatisticFarEastCharacters)
Set d = CreateObject("Scripting.Dictionary")
If a = vbYes Then
For Each Wd In ActiveDocument.Words
With Wd
If .Text Like "[一-龥]*" And Len(.Text) > 1 Then
If .Text Like "*[!一-龥]*" = False Then
d(.Text) = d(.Text) + 1
Else
For i = 1 To Len(.Text)
If Mid(.Text, i, 1) Like "[!一-龥]" Then Exit For
Next
With .Duplicate
.End = .Start + i - 1
For Each W In .Words
With W
If Len(.Text) > 1 Then
If Right(.Text, 1) Like "[!一-龥]" Then .End = .End - 1
d(.Text) = d(.Text) + 1
End If
End With
Next
End With
End If
End If
End With
Next
Else
filetext = ActiveDocument.Content.Text
For i = 1 To Len(filetext)
temp = Mid(filetext, i, 1)
If temp Like "[一-龥]" Then d(temp) = d(temp) + 1
Next
End If
b = d.keys
ReDim c(UBound(b))
For i = 0 To UBound(b)
c(i) = b(i) & vbTab & d(b(i))
Next
With Documents.Add.Content
.Text = "文档共有" & n & "个中文字符。共提取到" & d.Count _
& IIf(a = 6, "个中文词语", "个不同的汉字") & "，其出现次数分别为：" & vbCrLf & Join(c, vbCrLf)
.Parent.DefaultTabStop = .Characters.First.Font.Size * 6
.MoveStart wdParagraph
.Sort , 2, wdSortFieldNumeric, wdSortOrderDescending, 1, , , , , , wdSortSeparateByTabs
End With
MsgBox "提取完毕。用时" & Format(Timer - st, "0") & "秒。"
End Sub

复制代码

注：已对代码进行了首次修改，见10楼。

guzhen9315 · 发表于 2012-3-10 22:07

很好！谢谢！{:soso_e163:}

413191246se · 发表于 2012-3-11 01:37

谢谢楼主！不好意思，因水平太低，修改、添加、测试费了一个半小时，程序运行没有发现问题，样稿不大，但是是有手动换行符和不间断字符的文本，故意添加了一些半角、全角空格和制表符。有两点建议：一是统计结果最后不必出现提示消息框（及运行时间），这样给人以干净利落的感觉（现在代码也是喜欢能减一行就减一行，声明能在一行就在一行，行数太多显得程序太大）；二是提取的汉字词语长度建议仅为二、三、四、五字词为宜，多了没有必要（类似：工作、办公室、与时俱进、民主集中制，再长就没有统计的必要了）。我略微修改的代码如下（只是提示信息和最后加了个表格，主体程序看不懂也未改动——顺便请解释一下我的那个帖子：正文四号14磅，则首行缩进为0.99厘米中的公式 2*14*2.54/72=0.99 每个数字是啥意思，3Q！）：

Sub 词频统计()
Dim a As Byte, n As Long, filetext As String, d, Wd As Range, W As Range, b, c() As String, i As Long, temp As String
a = MsgBox("请选择——是：词频统计否：字频统计", vbYesNo + vbExclamation, "中文字词频统计")
n = ActiveDocument.Content.ComputeStatistics(wdStatisticFarEastCharacters)
Set d = CreateObject("Scripting.Dictionary")
If a = vbYes Then
      For Each Wd In ActiveDocument.Words
         With Wd
            If .Text Like "[一-龥]*" And Len(.Text) > 1 Then
                  If .Text Like "*[!一-龥]*" = False Then
                     d(.Text) = d(.Text) + 1
                  Else
                     For i = 1 To Len(.Text)
                        If Mid(.Text, i, 1) Like "[!一-龥]" Then Exit For
                     Next
                     With .Duplicate
                        .End = .Start + i - 1
                        For Each W In .Words
                              With W
                                 If Len(.Text) > 1 Then
                                    If Right(.Text, 1) Like "[!一-龥]" Then .End = .End - 1
                                    d(.Text) = d(.Text) + 1
                                 End If
                              End With
                        Next
                     End With
                  End If
            End If
         End With
      Next
Else
      filetext = ActiveDocument.Content.Text
      For i = 1 To Len(filetext)
         temp = Mid(filetext, i, 1)
         If temp Like "[一-龥]" Then d(temp) = d(temp) + 1
      Next
End If
b = d.keys
ReDim c(UBound(b))
For i = 0 To UBound(b)
      c(i) = b(i) & vbTab & d(b(i))
Next
With Documents.Add.Content
      .Text = IIf(a = 6, "词频统计", "字频统计") & "结果：文档共有" & n & "个中文字符，提取到" & d.Count _
         & IIf(a = 6, "个中文词语", "个不同的汉字") & "，其出现次数分别为：" & vbCrLf & Join(c, vbCrLf)
      .Parent.DefaultTabStop = .Characters.First.Font.Size * 6
      .MoveStart wdParagraph
      .Sort , 2, wdSortFieldNumeric, wdSortOrderDescending, 1, , , , , , wdSortSeparateByTabs
End With
ActiveDocument.Paragraphs(1).Range.Bold = True
ActiveDocument.Range(Start:=ActiveDocument.Paragraphs(2).Range.Start, End:=ActiveDocument.Paragraphs.Last.Range.End).Select
Selection.ConvertToTable Separator:=wdSeparateByTabs
Selection.Tables(1).Style = "网格型"
Selection.HomeKey Unit:=wdStory
End Sub

sylun · 发表于 2012-3-11 09:59

413191246se兄这样改也未尝不可，只是这样的改动对代码的直观性和测试的便捷性有所影响。我想关键的还是代码运行的适应性、提取结果的准确性或合理性和提取速度究竟如何。至于建议提取的汉字词语长度仅为二、三、四、五字词，我想word词典中超过4个字的词语不会很多（自行添加进去的除外），如果提取结果有这样的条目，且明显不是一个相对固定的词，则说明提取是不准确的或不合理的，有改进的必要。请老兄多提这方面的意见。

413191246se · 发表于 2012-3-11 10:12

谢谢！我以前经常练习打字，有一个《人民日报词频统计资料》的词频统计清单，也有一些自己加入的一些常用词，如果需要我可以截取高频的一些词作为附件上传。另外，词频统计是否是以二字词最先统计呢？如果以二、三、四、五字词来统计（五字词省略也可），就不必来那些拼凑的长词了。——原来运行时间也是为了观察一下提取速度，那还是采用原来的方案吧！——还有，假设我把旧代码“精简、优化”一下（其实也不会啥优化），可否有现成的程序（过程）运行时间测试的语句段或程序呢？

sylun · 发表于 2012-3-11 10:37

词频统计是否是以二字词最先统计呢？

不知是什么意思？如果只统计二字词，可修改一下代码，只是要注意，原来超过两个字的词语不应忽略，应重新考虑是否可再拆分出二字词的问题，这涉及到统计数字的准确性。
另外，所提的关于测试语句的问题，我想在此帖讨论不是很合适。

youliqi · 发表于 2012-3-11 14:39

收藏，学习学习

sqhsqhli · 发表于 2012-3-11 16:21

这个当是论坛上最快的一个，{:soso_e179:}

FENGJUN · 发表于 2012-6-13 14:30

代码统计是不准确的，具体问题请见附件。

文档共有1891个中文字符共提取到310个中文词语，其出现次数分别为：
生源 59
减肥 58
市场价 16
更多 14
商品 14
减肥药 12
颗粒 12
产品 11
排行 10
......

生源和减肥统计的数据与实际偏差很大。
作者能否再看看。

sylun · 发表于 2012-6-13 18:16

FENGJUN 发表于 2012-6-13 14:30
代码统计是不准确的，具体问题请见附件。

文档共有1891个中文字符共提取到310个中文词语，其出现次数分别 ...

是不很准确，主要原因是文档有语法和拼写错误时可能会导致遍历Words集合对象成员时重复计算，为何会这样还搞不清楚。另外，有些成对出现的中文标点符号也可能会导致词组的判断与我们通常的算法不一致。以下代码尝试对这两种情形进行一定程度的规避，也许还存在问题，请测试效果：

Sub ChineseCharCounting()
'统计汉字的字词频，并按降序排序
'中文词语的判断与Word的词典关联
Dim a As Byte
Dim n As Long
Dim TF As Boolean
Dim filetext As String
Dim d
Dim Wd As Range
Dim W As Range
Dim b
Dim e As Long
Dim c() As String
Dim i As Long
Dim temp As String
Dim st As Single
a = MsgBox("词频统计请按“是”，字频统计请按“否”", vbYesNo, "中文字词频统计")
st = Timer
Application.ScreenUpdating = False
n = ActiveDocument.Content.ComputeStatistics(wdStatisticFarEastCharacters)
If ActiveDocument.Content.Text Like "*[【】〖〗《》〈〉〔〕]*" Then TF = True
With ActiveDocument.Content.Find
.Text = "[【】〖〗《》〈〉〔〕]"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
Set d = CreateObject("Scripting.Dictionary")
If a = vbYes Then
For Each Wd In ActiveDocument.Words
With Wd
If .Start < e Then .Start = e
e = .End
If .Text Like "*[一-龥]*" And Len(.Text) > 1 Then
If .Text Like "*[!一-龥]*" = False And .Words.Count = 1 Then
d(.Text) = d(.Text) + 1
Else
For i = 1 To Len(.Text)
If Mid(.Text, i, 1) Like "[!一-龥]" Then Exit For
Next
With .Duplicate
.End = .Start + i - 1
For Each W In .Words
With W
If Len(.Text) > 1 Then
If Right(.Text, 1) Like "[!一-龥]" Then .End = .End - 1
If .Text Like "*[!一-龥]*" = False Then d(.Text) = d(.Text) + 1
End If
End With
Next
End With
End If
End If
End With
Next
Else
filetext = ActiveDocument.Content.Text
For i = 1 To Len(filetext)
temp = Mid(filetext, i, 1)
If temp Like "[一-龥]" Then d(temp) = d(temp) + 1
Next
End If
b = d.keys
ReDim c(UBound(b))
For i = 0 To UBound(b)
c(i) = b(i) & vbTab & d(b(i))
Next
If TF = True Then ActiveDocument.Undo 1
With Documents.Add.Content
.Text = "文档共有" & n & "个中文字符。共提取到" & d.Count _
& IIf(a = 6, "个中文词语", "个不同的汉字") & "，其出现次数分别为：" & vbCrLf & Join(c, vbCrLf)
.Parent.DefaultTabStop = .Characters.First.Font.Size * 6
.MoveStart wdParagraph
.Sort , 2, wdSortFieldNumeric, wdSortOrderDescending, 1, , , , , , wdSortSeparateByTabs
End With
MsgBox "提取完毕。用时" & Format(Timer - st, "0") & "秒。"
Application.ScreenUpdating = True
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[分享] Word文档的中文字词频统计