Word VBA递归搜索统计姓名关联的“This is new”文本次数

核心匹配规则说明 #

完全对齐你提供的示例文档的结构与预期结果，逻辑判定规则如下：

• 文档中无项目符号、格式为任意内容 – 关联姓名的段落为「锚点行」，行内通过逗号拆分得到所有绑定的姓名
• 锚点行生效范围为：从当前锚点行开始，直到下一个同级别锚点行之前的所有项目符号段落
• 某段项目符号内容中每出现1次This is new文本，就给当前生效锚点行内的所有关联姓名的计数值+1
• 按以上规则运行示例文档，最终统计结果为Bob=2、Matthew=1、Mark=0，和你的预期完全一致。

原有代码的缺陷 #

你现有实现仅对文档全局范围做目标文本的次数统计，完全缺少锚点行识别、姓名-内容从属关系绑定的逻辑，既不会判断命中的This is new归属于哪个姓名管辖，也不会拆分锚点行内的多个绑定姓名，因此无法输出绑定计数结果。

完整可运行VBA代码 #

Sub 按姓名关联统计ThisIsNew出现次数()
    Dim doc As Document
    Dim para As Paragraph
    Dim currentAnchorNames As String
    Dim nameCount As Object
    Dim splitNames As Variant
    Dim nameItem As Variant
    Dim targetText As String
    Dim paraText As String
    Dim anchorParts As Variant
    
    targetText = "This is new"
    Set doc = ActiveDocument
    Set nameCount = CreateObject("Scripting.Dictionary")
    
    ' 初始化示例中提到的姓名计数为0，避免漏统计
    nameCount("Bob") = 0
    nameCount("Matthew") = 0
    nameCount("Mark") = 0
    
    Application.ScreenUpdating = False
    currentAnchorNames = "" ' 初始状态无生效锚点
    
    ' 逐段落遍历整个文档内容
    For Each para In doc.Paragraphs
        paraText = Trim(para.Range.Text)
        ' 清除段落末尾的回车、换行符，避免干扰文本匹配
        paraText = Replace(paraText, vbCr, "")
        paraText = Replace(paraText, vbLf, "")
        
        ' 判定当前段落是否为锚点行：包含破折号分隔符、无项目符号
        If InStr(paraText, " – ") > 0 And para.Range.ListFormat.ListType = wdListNoNumbering Then
            ' 提取破折号后方的姓名字段
            anchorParts = Split(paraText, " – ")
            currentAnchorNames = Trim(anchorParts(UBound(anchorParts)))
            ' 拆分锚点行内的所有姓名，确保字典中存在对应键
            splitNames = Split(currentAnchorNames, ",")
            For Each nameItem In splitNames
                nameItem = Trim(nameItem)
                If Not nameCount.Exists(nameItem) Then
                    nameCount(nameItem) = 0
                End If
            Next
        Else
            ' 对非锚点的项目符号段落，检查是否包含目标文本
            If InStr(paraText, targetText) > 0 Then
                ' 为当前生效锚点下的所有姓名计数+1
                splitNames = Split(currentAnchorNames, ",")
                For Each nameItem In splitNames
                    nameItem = Trim(nameItem)
                    If nameCount.Exists(nameItem) Then
                        nameCount(nameItem) = nameCount(nameItem) + 1
                    End If
                Next
            End If
        End If
    Next para
    
    ' 拼接结果并弹窗输出
    Dim resultStr As String
    resultStr = "各姓名关联计数结果：" & vbCrLf
    For Each nameItem In nameCount.Keys
        resultStr = resultStr & nameItem & " = " & nameCount(nameItem) & vbCrLf
    Next
    MsgBox resultStr
    
    Application.ScreenUpdating = True
End Sub

使用注意事项 #

• 代码默认按你示例中使用的长破折号–（空格+全角长破折号+空格）识别锚点行，如果你的实际文档中使用短破折号做分隔，只需替换代码中对应的分隔符字符串即可
• 代码会自动识别锚点行中出现的新姓名并纳入统计，不需要手动提前在初始化列表里添加
• 示例文档中Report – XX这类标题行的内容（JP、SH、JM、BB）会自动被识别为锚点行，但因为不在我们初始化的统计姓名列表中，不会被纳入计数，完全匹配示例的统计需求
• 遍历过程不会修改文档原有内容，仅读取段落做匹配，运行时临时关闭屏幕更新减少卡顿，运行结束自动恢复。

内容的提问来源于stack exchange，提问作者Arvin