Excel VBA 词频统计宏

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

实现方法

1. 准备数据

   • 确保待分析的文本位于Excel的某一列（如A列）。
   • 在另一列（如B列）列出需要统计的目标单词或短语。

2. 编写VBA宏

   • 打开VBA编辑器（Alt + F11），插入新模块。
   • 使用For Each循环遍历目标词列表，并利用InStr或Split函数计算每个词在文本中的出现次数。
   • 将统计结果输出到指定列（如C列）。

3. 优化与扩展

   • 可调整宏以支持不区分大小写的匹配（使用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 Long
    Dim txa As String
    Dim z, t
    
    t = Timer '记录开始时间
    Application.ScreenUpdating = False '关闭屏幕更新以提高速度
    
    Range(xCol).Clear '清空指定列
    
    '清除A列中的错误值
    On Error Resume Next
    Range("A:A").SpecialCells(xlCellTypeFormulas, xlErrors).ClearContents
    Range("A:A").SpecialCells(xlConstants, xlErrors).ClearContents
    On Error GoTo 0
    
    '获取A列最后一行行号
    j = Range("A" & Rows.Count).End(xlUp).Row
    
    '将A列内容合并为一个字符串
    If j < 65000 Then
        txa = Join(Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp))), " ")
    Else
        '如果数据超过65000行，分段处理
        For i = 1 To j Step 65000
            txa = txa & Join(Application.Transpose(Range("A" & i).Resize(65000)), " ") & " "
        Next
    End If
    
    '处理sNumber参数
    z = Split(sNumber, ",")
    
    '调用处理函数
    For i = LBound(z) To UBound(z)
        Call toProcessY(CLng(z(i)), txa, xPattern)
    Next
    
    '调整列宽，恢复屏幕更新
    Range(xCol).Columns.AutoFit
    Application.ScreenUpdating = True
    
    Debug.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 Object
    Dim i As Long, rc As Long
    Dim 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) Then
           tx = regEx.Replace(tx, " ")
        End If
        
        tx = Trim(tx) '去除首尾空格
               
        '替换非单词字符（保留空格）
        regEx.Pattern = "[^" & xP & " ]+"
        If regEx.Test(tx) Then
           tx = 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 matches
        d(CStr(x)) = d(CStr(x)) + 1
    Next
 
    '处理不同组合情况（针对n>1）
    For i = 1 To n - 1
        regEx.Pattern = "^[" & xP & "]+ "
        If regEx.Test(tx) Then
           tx = regEx.Replace(tx, "") '移除每行的第一个单词
           
           regEx.Pattern = Trim(WorksheetFunction.Rept("[" & xP & "]+ ", n))
           Set matches = regEx.Execute(tx)
           
           For Each x In matches
               d(CStr(x)) = d(CStr(x)) + 1
           Next
        End If
    Next

    '如果没有找到结果则退出
    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.Count
        Case 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 = 0
            For Each q In d.Keys
                i = i + 1
                va(i, 1) = q: va(i, 2) = d(q)
            Next
            .Value = va
        Case Else
            MsgBox "处理取消，结果超过1048500行"
        End Select
        
        '排序：按词频降序，按单词升序
        .Sort Key1:=.Cells(1, 2), Order1:=xlDescending, _
              Key2:=.Cells(1, 1), Order2:=xlAscending, Header:=xlNo
    End With
    
    '添加标题
    Cells(1, rc + 2) = n & " 单词组合"
    Cells(1, rc + 3) = "出现次数"
End Sub

六、使用步骤

1. 将待分析文本放入A列（从A1开始）
2. 修改sNumber参数设置要统计的单词组合长度
3. 修改xPattern参数定义单词字符（默认包含字母、数字、下划线和撇号）
4. 运行Word_Phrase_Frequency_v1宏
5. 结果将输出到右侧空白列，包含单词/短语和出现次数，并按频率排序

七、注意事项

1. 大数据量处理可能需要较长时间
2. 结果最多支持1,048,500行
3. 正则表达式模式可根据需要调整xPattern参数
4. 如需统计中文，需要修改xPattern参数包含中文字符