Word VBA近词重复检测宏出现假阳性匹配问题求助

我开发了一个检测文本中近距重复词的Word宏，但它会把作为其他单词一部分的搜索词误判为匹配项。比如在句子This is one clause, and this isn't another.里，宏正确高亮了重复的"this"，但错误高亮了"is"——因为它是"isn't"的组成部分。

宏的逻辑是：提取一个单词，在后续n个单词范围内（设置了MatchWholeWord = true）搜索该词，找到就高亮匹配项；之后检查是否找到匹配，若找到则高亮原搜索词。判断搜索是否成功的环节疑似有bug，但我想不到替代的验证方式。

（宏已简化为基础功能；完整版会先筛选掉高频词再执行搜索。）

原代码：

Sub FindCloseRepetitionDebug()

    Dim rAllContent As Range
    Dim rLastSetWord As Range
    Dim rLastSearchWord As Range
    Dim rSearchSet As Range
    Dim sCurrentWord As String
    Dim iLengthAllContent As Long
    Dim iComparisonLength As Integer
    Dim rCurrentSet As Range
    
    iComparisonLength = 10
     
    Set rAllContent = Selection.Range
    rAllContent.WholeStory

    iLengthAllContent = rAllContent.Words.Count
    Set rLastSetWord = rAllContent.Words(iLengthAllContent)
    If iLengthAllContent < iComparisonLength Then iComparisonLength = iLengthAllContent

    Set rCurrentSet = rAllContent.Words(1)
    rCurrentSet.SetRange Start:=rAllContent.Words(1).Start, End:=rAllContent.Words(iComparisonLength).End
 
    Do
        sCurrentWord = Trim(rCurrentSet.Words(1).Text)
        Set rSearchSet = rCurrentSet.Words(1)
        rSearchSet.SetRange Start:=rCurrentSet.Words(2).Start, End:=rCurrentSet.Words(iComparisonLength).End
        If Len(sCurrentWord) > 1 Then
            With rSearchSet.Find
                With .Replacement
                    .Highlight = True
                End With
                .Execute Forward:=True, MatchWholeWord:=True, FindText:=sCurrentWord, Replace:=wdReplaceAll, ReplaceWith:="", Format:=True
                If .Found = True Then rCurrentSet.Words(1).HighlightColorIndex = wdTurquoise
            End With
        End If
        Set rLastSearchWord = rCurrentSet.Words(iComparisonLength)
        If rLastSearchWord.IsEqual(Range:=rLastSetWord) = False Then
            rCurrentSet.MoveStart Unit:=wdWord, Count:=1
            rCurrentSet.MoveEnd Unit:=wdWord, Count:=1
        ElseIf rCurrentSet.IsEqual(Range:=rLastSetWord) = False Then
            rCurrentSet.MoveStart Unit:=wdWord, Count:=1
            If iComparisonLength > 2 Then
                iComparisonLength = iComparisonLength - 1
                ElseIf sCurrentWord = rLastSetWord.Text Then
                    rCurrentSet.MoveStart Unit:=wdWord, Count:=-1
                    rCurrentSet.HighlightColorIndex = wdTurquoise
                    Exit Do
                Else: Exit Do
            End If
            Else: Exit Do
        End If
    Loop
    
End Sub

问题根源 #

核心问题有两个：

• Word的Words集合会将撇号（'）视为单词分隔符，导致"isn't"被拆分为"is"和"n't"两个独立项，此时MatchWholeWord:=True会把拆分出的"is"判定为完整单词，触发误匹配。
• 使用Replace:=wdReplaceAll时，Find.Found属性无法准确反映实际匹配结果，因为替换操作会重置查找状态。

修复后的代码 #

Sub FindCloseRepetitionFixed()
    Dim rAllContent As Range
    Dim rLastSetWord As Range
    Dim rSearchSet As Range
    Dim sCurrentWord As String
    Dim iLengthAllContent As Long
    Dim iComparisonLength As Integer
    Dim rCurrentSet As Range
    Dim foundMatch As Boolean
    
    iComparisonLength = 10
     
    Set rAllContent = Selection.Range
    rAllContent.WholeStory

    iLengthAllContent = rAllContent.Words.Count
    Set rLastSetWord = rAllContent.Words(iLengthAllContent)
    If iLengthAllContent < iComparisonLength Then iComparisonLength = iLengthAllContent

    Set rCurrentSet = rAllContent.Words(1)
    rCurrentSet.SetRange Start:=rAllContent.Words(1).Start, End:=rAllContent.Words(iComparisonLength).End
 
    Do
        sCurrentWord = Trim(rCurrentSet.Words(1).Text)
        ' 跳过短词和非字母数字开头的伪单词（如拆分出的'n't）
        If Len(sCurrentWord) > 1 And sCurrentWord Like "[A-Za-z0-9]*" Then
            Set rSearchSet = rCurrentSet.Duplicate
            rSearchSet.SetRange Start:=rCurrentSet.Words(2).Start, End:=rCurrentSet.End
            foundMatch = False
            
            With rSearchSet.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Replacement.Highlight = True
                .Forward = True
                .MatchWholeWord = True
                .MatchCase = False ' 可根据需求改为True开启大小写敏感匹配
                .FindText = sCurrentWord
                .Wrap = wdFindStop ' 限制查找范围，避免循环查找整个文档
                .Format = True
                
                ' 先执行一次查找确认存在匹配，再执行替换
                If .Execute Then
                    foundMatch = True
                    .Execute Replace:=wdReplaceAll
                End If
            End With
            
            If foundMatch Then
                rCurrentSet.Words(1).HighlightColorIndex = wdTurquoise
            End If
        End If
        
        ' 移动当前处理范围
        Set rLastSearchWord = rCurrentSet.Words(iComparisonLength)
        If Not rLastSearchWord.IsEqual(rLastSetWord) Then
            rCurrentSet.MoveStart Unit:=wdWord, Count:=1
            rCurrentSet.MoveEnd Unit:=wdWord, Count:=1
        ElseIf Not rCurrentSet.IsEqual(rLastSetWord) Then
            rCurrentSet.MoveStart Unit:=wdWord, Count:=1
            If iComparisonLength > 2 Then
                iComparisonLength = iComparisonLength - 1
            ElseIf Trim(sCurrentWord) = Trim(rLastSetWord.Text) Then
                rCurrentSet.MoveStart Unit:=wdWord, Count:=-1
                rCurrentSet.HighlightColorIndex = wdTurquoise
                Exit Do
            Else
                Exit Do
            End If
        Else
            Exit Do
        End If
    Loop
    
End Sub

关键修复说明 #

• 过滤伪单词：通过sCurrentWord Like "[A-Za-z0-9]*"判断，跳过由标点拆分出来的非有效单词（如"n't"），避免误触发搜索。
• 修复匹配状态判断：先执行一次Execute查找确认存在匹配，再执行ReplaceAll，确保foundMatch变量能准确反映是否找到重复词。
• 限制查找范围：添加.Wrap = wdFindStop，确保查找仅在当前设定的后续n个单词范围内进行，不会超出边界循环查找。
• 清理格式缓存：每次查找前调用.ClearFormatting，避免之前的格式设置干扰查找结果。

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