如何逐个查找文档中首字母大写单词的重复/相似词？

一、提取所有首字母大写的唯一单词 #

先通过VBA遍历文档，把所有匹配到的首字母大写单词存入集合实现去重，避免重复处理相同单词：

Sub ExtractCapitalizedWords()
    Dim foundWords As New Collection
    Dim rng As Range
    Dim wordText As String
    
    ' 初始化查找规则（沿用你提供的通配符匹配）
    With Selection.Find
        .Text = "<([A-Z][0-9A-Za-z]{1,15})>"
        .MatchWildcards = True
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
    End With
    
    ' 遍历所有匹配项，存入集合去重
    Set rng = Selection.Range
    Do While Selection.Find.Execute
        wordText = Selection.Text
        ' 利用集合的Key属性自动去重（大小写统一为大写作为Key）
        On Error Resume Next
        foundWords.Add wordText, Key:=UCase(wordText)
        On Error GoTo 0
        ' 移动光标避免死循环
        Selection.Collapse wdCollapseEnd
    Loop
    Selection.SetRange rng.Start, rng.End ' 恢复原选择范围
    
    ' 调用后续的重复/相似词查找逻辑
    FindDuplicatesAndSimilar foundWords
End Sub

二、逐个查找单词的重复/相似词 #

针对每个提取到的单词，分别处理精确重复、形态变体（复数/所有格）、拼写相近词三种场景：

Sub FindDuplicatesAndSimilar(wordCollection As Collection)
    Dim wordItem As Variant
    Dim rng As Range
    Dim searchPattern As String
    
    For Each wordItem In wordCollection
        Set rng = ActiveDocument.Content
        Debug.Print "=== 当前处理单词: " & wordItem & " ==="
        
        ' 1. 查找精确重复（忽略大小写）
        With rng.Find
            .Text = "<" & wordItem & ">"
            .MatchCase = False
            .MatchWholeWord = True
            .MatchWildcards = False
            .Forward = True
            .Wrap = wdFindStop
            
            Do While .Execute
                Debug.Print "精确匹配: " & rng.Text & " (位置: " & rng.Start & ")"
                rng.Collapse wdCollapseEnd
            Loop
        End With
        
        ' 2. 查找形态变体（复数、所有格）
        searchPattern = "<" & wordItem & "[s']?>" ' 匹配末尾的s或'
        Set rng = ActiveDocument.Content
        With rng.Find
            .Text = searchPattern
            .MatchWildcards = True
            .MatchCase = False
            .Forward = True
            .Wrap = wdFindStop
            
            Do While .Execute
                ' 排除原单词本身，只保留变体
                If UCase(rng.Text) <> UCase(wordItem) Then
                    Debug.Print "形态变体: " & rng.Text & " (位置: " & rng.Start & ")"
                End If
                rng.Collapse wdCollapseEnd
            Loop
        End With
        
        ' 3. 查找拼写相近词（依赖Word拼写检查词典）
        Dim suggestions As Variant
        suggestions = GetSpellingSuggestions(wordItem)
        If Not IsEmpty(suggestions) Then
            Debug.Print "拼写相近词列表:"
            For Each sugg In suggestions
                Set rng = ActiveDocument.Content
                With rng.Find
                    .Text = "<" & sugg & ">"
                    .MatchWholeWord = True
                    .MatchCase = False
                    .Forward = True
                    .Wrap = wdFindStop
                    
                    Do While .Execute
                        Debug.Print "拼写相近匹配: " & rng.Text & " (位置: " & rng.Start & ")"
                        rng.Collapse wdCollapseEnd
                    Loop
                End With
            Next sugg
        End If
    Next wordItem
End Sub

' 辅助函数：获取单词的拼写建议
Function GetSpellingSuggestions(word As String) As Variant
    Dim suggList As Collection
    Set suggList = New Collection
    
    For Each sugg In Application.GetSpellingSuggestions(word)
        suggList.Add sugg.Name
    Next sugg
    
    ' 集合转数组返回
    If suggList.Count > 0 Then
        Dim arr() As String
        ReDim arr(1 To suggList.Count)
        For i = 1 To suggList.Count
            arr(i) = suggList(i)
        Next i
        GetSpellingSuggestions = arr
    Else
        GetSpellingSuggestions = Empty
    End If
End Function

使用说明 #

1. 打开Word的VBA编辑器（快捷键Alt+F11）
2. 插入新模块，粘贴上述所有代码
3. 返回文档，运行ExtractCapitalizedWords过程
4. 结果会输出到VBA的立即窗口（快捷键Ctrl+G打开），也可根据需求修改代码，将结果写入文档或弹窗展示

自定义调整 #

• 若只需精确重复，可删除形态变体和拼写相近词的处理逻辑
• 通配符{1,15}可调整为更大的数值，匹配更长的首字母大写单词
• 拼写相近功能依赖Word的语言词典，确保文档语言设置与目标单词一致

内容的提问来源于stack exchange，提问作者Balasubramaniyan-mac