【牛马技巧】word统计每一段的字数接近“字数统计”

vbnet 复制代码
Option Explicit

Sub CountWordsUnderHeadings_Revised()

    Dim doc As Document
    Dim para As Paragraph
    Dim currentH1Para As Paragraph, currentH2Para As Paragraph, currentH3Para As Paragraph
    Dim countH1 As Long, countH2 As Long, countH3 As Long
    Dim outlineLevel As WdOutlineLevel
    Dim tempRange As Range

    Set doc = ActiveDocument
    If doc Is Nothing Then
        MsgBox "没有活动的文档。", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False ' 关闭屏幕更新以提高速度

    ' --- 步骤 1: 清理之前可能添加的字数统计 ---
    For Each para In doc.Paragraphs
        If para.outlineLevel >= wdOutlineLevel1 And para.outlineLevel <= wdOutlineLevel3 Then
            Set tempRange = para.Range
            ' 查找模式 " (任意字符 字)"，例如 " (123 字)"
            With tempRange.Find
                .ClearFormatting
                ' --- 修改点：修正通配符表达式 ---
                .Text = " \(\* 字\)" ' 原为 " (*) 字)"
                ' 解释：
                ' " "  : 匹配开头的空格
                ' "\(" : 匹配字面上的左括号 (
                ' "*"  : 匹配任意数量的字符 (即数字)
                ' " "  : 匹配数字和"字"之间的空格
                ' "字" : 匹配汉字"字"
                ' "\)" : 匹配字面上的右括号 )
                ' ----------------------------------
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindStop
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = True ' 启用通配符
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute Replace:=wdReplaceAll ' 在当前段落范围内替换所有匹配项
            End With
        End If
    Next para
    ' --- 清理结束 ---


    ' --- 步骤 2: 初始化计数器和标题段落引用 ---
    Set currentH1Para = Nothing
    Set currentH2Para = Nothing
    Set currentH3Para = Nothing
    countH1 = 0
    countH2 = 0
    countH3 = 0
    ' --- 初始化结束 ---

    ' --- 步骤 3: 遍历段落并计数 ---
    For Each para In doc.Paragraphs
        outlineLevel = para.outlineLevel

        Select Case outlineLevel
            Case wdOutlineLevel1 ' 遇到1级标题
                Call AppendCountToHeading(currentH3Para, countH3)
                Call AppendCountToHeading(currentH2Para, countH2)
                Call AppendCountToHeading(currentH1Para, countH1)

                Set currentH1Para = para
                countH1 = 0
                Set currentH2Para = Nothing
                countH2 = 0
                Set currentH3Para = Nothing
                countH3 = 0

            Case wdOutlineLevel2 ' 遇到2级标题
                Call AppendCountToHeading(currentH3Para, countH3)
                If Not currentH2Para Is Nothing Then '确保不是新H1下的第一个H2导致清空旧H2计数
                    Call AppendCountToHeading(currentH2Para, countH2)
                End If
                
                Set currentH2Para = para
                countH2 = 0
                Set currentH3Para = Nothing
                countH3 = 0

            Case wdOutlineLevel3 ' 遇到3级标题
                Call AppendCountToHeading(currentH3Para, countH3)
                
                Set currentH3Para = para
                countH3 = 0

            Case wdOutlineLevelBodyText ' 正文文本
                If Len(Trim(para.Range.Text)) > 1 Then ' 排除仅包含段落标记的空行
                    Dim wordsInPara As Long
                    ' --- 修改点：使用 ComputeStatistics ---
                    wordsInPara = para.Range.ComputeStatistics(wdStatisticWords)
                    ' --- 原代码：wordsInPara = para.Range.Words.Count ---

                    If Not currentH1Para Is Nothing Then
                        countH1 = countH1 + wordsInPara
                    End If
                    If Not currentH2Para Is Nothing Then
                        countH2 = countH2 + wordsInPara
                    End If
                    If Not currentH3Para Is Nothing Then
                        countH3 = countH3 + wordsInPara
                    End If
                End If
        End Select
    Next para
    ' --- 遍历结束 ---

    ' --- 步骤 4: 追加文档末尾最后一个标题的计数 ---
    Call AppendCountToHeading(currentH3Para, countH3)
    Call AppendCountToHeading(currentH2Para, countH2)
    Call AppendCountToHeading(currentH1Para, countH1)
    ' --- 追加结束 ---

    Application.ScreenUpdating = True ' 恢复屏幕更新
    MsgBox "所有标题下的正文字数统计完成！", vbInformation

End Sub

Private Sub AppendCountToHeading(ByRef headingPara As Paragraph, ByVal wordCount As Long)
    ' 辅助子程序，用于将字数追加到标题末尾
    If Not headingPara Is Nothing Then
        If wordCount > 0 Then
            Dim rng As Range
            Set rng = headingPara.Range
            rng.Collapse Direction:=wdCollapseEnd
            rng.MoveEnd Unit:=wdCharacter, Count:=-1 ' 排除末尾的段落标记
            
            ' 简单的重复添加检查 (基于添加的格式)
            ' 如果标题末尾已经是 " (XXX 字)" 格式，则不再添加
            ' 这个检查是为了防止在一次运行中，如果逻辑有微小瑕疵导致重复处理同一个标题时发生
            ' 主要的清理工作由主程序开始时的Find/Replace完成
            Dim currentText As String
            currentText = rng.Text
            ' 检查是否已经以 " (...) 字)" 结尾 (一个粗略的检查)
            If Not (InStr(currentText, " (") > 0 And Right(Trim(currentText), 3) = " 字)") Then
                 rng.InsertAfter " (" & wordCount & " 字)"
            ' 更精确的检查，与清理的模式对应
            ' Dim tempFind As Find
            ' Set tempFind = rng.Find
            ' tempFind.ClearFormatting
            ' tempFind.Text = " \(\* 字\)" ' 查找是否已存在此模式
            ' tempFind.MatchWildcards = True
            ' If Not tempFind.Execute Then ' 如果未找到已存在的标记
            '    rng.InsertAfter " (" & wordCount & " 字)"
            ' End If
            End If
        End If
        Set headingPara = Nothing ' 处理完后重置
    End If
End Sub
使用方法：
打开VBA编辑器： 在 Word 中，按下 Alt + F11。
插入模块： 在 VBA 编辑器中，选择菜单栏的 "插入" -> "模块"。
粘贴代码： 将上面的 修改后 的 VBA 代码复制并粘贴到新打开的模块代码窗口中。
运行宏：
- 关闭 VBA 编辑器。
- 在 Word 中，通过 "开发工具" 选项卡下的 "宏" 按钮找到并运行名为 CountWordsUnderHeadings_Revised 的宏。