ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1554|回复: 0

求助: 如何提出Word文件中出现频率较高的短语

[复制链接]

TA的精华主题

TA的得分主题

发表于 2015-5-20 11:36 | 显示全部楼层 |阅读模式
请教一下,能否用VBA实现提出Word文件中出现频率较高的短语, 之前提出出现频率高的单词的方法已经有了,不知能否在此基础上改进一下,提出短语。(当然会后很多不是短语的组合,但其出现的频率也往往较低)

附上之前已发表的计算单词出现频率的程序(是从本版下载的,不知是哪位大侠编写的了)。
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 = 1
     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 = 1 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

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 02:50 , Processed in 0.041373 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表