Excel VBA 词频统计宏

在Excel中，我们经常需要分析文本数据，例如统计某个单词或短语在文档中出现的次数。虽然Excel本身提供了一些文本处理功能（如COUNTIF），但对于复杂的词频统计，手动操作可能效率低下。这时，VBA宏可以自动化这一过程，快速生成词频统计表。

实现方法

准备数据
- 确保待分析的文本位于Excel的某一列（如A列）。
- 在另一列（如B列）列出需要统计的目标单词或短语。
编写VBA宏
- 打开VBA编辑器（Alt + F11），插入新模块。
- 使用For Each循环遍历目标词列表，并利用InStr或Split函数计算每个词在文本中的出现次数。
- 将统计结果输出到指定列（如C列）。
优化与扩展
- 可调整宏以支持不区分大小写的匹配（使用LCase函数）。
- 若需统计多个文本区域，可扩展宏以遍历多个工作表或工作簿。

一、宏功能概述

这段VBA代码用于在Excel中统计单词或短语的出现频率，支持统计1个单词、2个单词组合或3个单词组合的出现次数。

二、准备工作

'1. 添加引用："Microsoft VBScript Regular Expressions 5.5"
'   在VBA编辑器中：工具 -> 引用 -> 勾选"Microsoft VBScript Regular Expressions 5.5" -> 确定
'2. 数据必须放在A列，从A1开始
'3. 运行Word_Phrase_Frequency_v1宏

三、关键参数设置

'--- 修改以下参数以适应你的需求 -----------------------------------Const sNumber As String = "1,2,3"  '"1,2,3"
'sNumber = "1"  只统计单个单词频率
'sNumber = "1,2,3"  统计1个、2个和3个单词组合的频率Const xPattern As String = "A-Z0-9_'"
'定义单词字符，上述模式将包含字母、数字、下划线和撇号作为单词字符
'例如："you're"会被视为一个单词，"aa_bb"也会被视为一个单词Const xCol As String = "C:ZZ" '要清空的列范围

四、主程序解析

Sub Word_Phrase_Frequency_v1()Dim i As Long, j As LongDim txa As StringDim z, tt = Timer '记录开始时间Application.ScreenUpdating = False '关闭屏幕更新以提高速度Range(xCol).Clear '清空指定列'清除A列中的错误值On Error Resume NextRange("A:A").SpecialCells(xlCellTypeFormulas, xlErrors).ClearContentsRange("A:A").SpecialCells(xlConstants, xlErrors).ClearContentsOn Error GoTo 0'获取A列最后一行行号j = Range("A" & Rows.Count).End(xlUp).Row'将A列内容合并为一个字符串If j < 65000 Thentxa = Join(Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp))), " ")Else'如果数据超过65000行，分段处理For i = 1 To j Step 65000txa = txa & Join(Application.Transpose(Range("A" & i).Resize(65000)), " ") & " "NextEnd If'处理sNumber参数z = Split(sNumber, ",")'调用处理函数For i = LBound(z) To UBound(z)Call toProcessY(CLng(z(i)), txa, xPattern)Next'调整列宽，恢复屏幕更新Range(xCol).Columns.AutoFitApplication.ScreenUpdating = TrueDebug.Print "处理完成，耗时: " & Timer - t & " 秒"
End Sub

五、核心处理函数

Sub toProcessY(n As Long, ByVal tx As String, xP As String)'n: 要统计的单词组合长度'tx: 待处理的文本'xP: 单词字符模式Dim regEx As Object, matches As Object, x As Object, d As ObjectDim i As Long, rc As LongDim va, q'创建正则表达式对象Set regEx = CreateObject("VBScript.RegExp")With regEx.Global = True '全局匹配.MultiLine = True '多行模式.ignorecase = True '忽略大小写End With'处理多单词组合的情况If n > 1 Then'移除多余空格regEx.Pattern = "( ){2,}"If regEx.Test(tx) Thentx = regEx.Replace(tx, " ")End Iftx = Trim(tx) '去除首尾空格'替换非单词字符（保留空格）regEx.Pattern = "[^" & xP & " ]+"If regEx.Test(tx) Thentx = regEx.Replace(tx, vbLf)End If'移除每行开头的空格tx = Replace(tx, vbLf & " ", vbLf & "")End If'创建字典对象存储词频Set d = CreateObject("scripting.dictionary")d.CompareMode = vbTextCompare '文本比较模式（不区分大小写）'构建正则表达式模式匹配n个单词的组合regEx.Pattern = Trim(WorksheetFunction.Rept("[" & xP & "]+ ", n))Set matches = regEx.Execute(tx)'统计词频For Each x In matchesd(CStr(x)) = d(CStr(x)) + 1Next'处理不同组合情况（针对n>1）For i = 1 To n - 1regEx.Pattern = "^[" & xP & "]+ "If regEx.Test(tx) Thentx = regEx.Replace(tx, "") '移除每行的第一个单词regEx.Pattern = Trim(WorksheetFunction.Rept("[" & xP & "]+ ", n))Set matches = regEx.Execute(tx)For Each x In matchesd(CStr(x)) = d(CStr(x)) + 1NextEnd IfNext'如果没有找到结果则退出If d.Count = 0 Then MsgBox "没有找到 " & n & " 个单词的组合": Exit Sub'确定输出列rc = Cells(1, Columns.Count).End(xlToLeft).Column'输出结果With Cells(2, rc + 2).Resize(d.Count, 2)Select Case d.CountCase Is < 65536 'Transpose函数限制65536个项目.Value = Application.Transpose(Array(d.Keys, d.Items))Case Is <= 1048500'大数据量处理ReDim va(1 To d.Count, 1 To 2)i = 0For Each q In d.Keysi = i + 1va(i, 1) = q: va(i, 2) = d(q)Next.Value = vaCase ElseMsgBox "处理取消，结果超过1048500行"End Select'排序：按词频降序，按单词升序.Sort Key1:=.Cells(1, 2), Order1:=xlDescending, _Key2:=.Cells(1, 1), Order2:=xlAscending, Header:=xlNoEnd With'添加标题Cells(1, rc + 2) = n & " 单词组合"Cells(1, rc + 3) = "出现次数"
End Sub