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的宏。