修复Word VBA宏：查找参考编号前最常见双词串

完整代码 #

Sub FindMostFrequentPrecedingTwoWords()
    Dim targetNum As String
    targetNum = InputBox("请输入参考编号（如102）：", "输入参考编号")
    If targetNum = "" Then Exit Sub
    
    Dim doc As Document
    Set doc = ActiveDocument
    
    Dim findRange As Range
    Set findRange = doc.Content
    
    Dim wordCounts As Object
    Set wordCounts = CreateObject("Scripting.Dictionary")
    
    ' 查找所有目标编号实例
    With findRange.Find
        .Text = targetNum
        .Forward = True
        .Wrap = wdFindStop
        .MatchWholeWord = True ' 确保匹配完整编号，避免部分匹配
        .MatchCase = False
        .Execute
        
        Do While .Found
            ' 定位到当前匹配项起始位置，向前取两个单词
            Dim prevRange As Range
            Set prevRange = findRange.Duplicate
            prevRange.Collapse wdCollapseStart
            
            ' 向前扩展选中两个单词，处理文档开头的边界情况
            prevRange.MoveStart wdWord, -2
            If prevRange.Start < doc.Content.Start Then
                prevRange.Start = doc.Content.Start
            End If
            
            Dim twoWords As String
            twoWords = Trim(prevRange.Text)
            
            ' 仅统计有效双词串
            If UBound(Split(twoWords, " ")) = 1 Then
                If wordCounts.Exists(twoWords) Then
                    wordCounts(twoWords) = wordCounts(twoWords) + 1
                Else
                    wordCounts(twoWords) = 1
                End If
            End If
            
            ' 继续查找下一个实例
            .Execute findRange:=findRange
        Loop
    End With
    
    ' 计算并返回众数
    If wordCounts.Count = 0 Then
        MsgBox "未找到编号" & targetNum & "的实例，或无有效前置双词串。"
        Exit Sub
    End If
    
    Dim maxCount As Integer
    Dim mostFreqWords As String
    maxCount = 0
    mostFreqWords = ""
    
    Dim key As Variant
    For Each key In wordCounts.Keys
        If wordCounts(key) > maxCount Then
            maxCount = wordCounts(key)
            mostFreqWords = key
        ElseIf wordCounts(key) = maxCount Then
            mostFreqWords = mostFreqWords & ", " & key
        End If
    Next key
    
    MsgBox "编号" & targetNum & "的前置双词串众数为：" & vbCrLf & mostFreqWords & vbCrLf & "出现次数：" & maxCount
End Sub

关键修复说明 #

• 精确匹配编号：添加MatchWholeWord = True，避免将包含目标编号的长数字（如160）误识别为目标编号16，解决测试场景中的匹配失效问题。
• 边界情况处理：当目标编号位于文档开头、前置不足两个单词时，自动调整提取范围，避免无效内容干扰统计。
• 有效内容过滤：仅当提取结果恰好是两个单词时才计入统计，排除单个单词、空值等无效情况。
• 查找逻辑优化：指定后续查找范围为当前匹配项之后，避免重复匹配同一位置，提升查找效率。
• 并列众数兼容：如果多个双词串出现次数相同，会全部列出，结果更全面。

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