我的创作纪念日，给大家分享wordVBA在文档中查重的代码

Sub 调用函数()

    Call 查找是否有重复连续字符(10)

End Sub



Sub 查找是否有重复连续字符(x As Integer)
    '获取用户输入的字符串长度
    Dim charCount As Integer
    charCount = x
'    charCount = InputBox("请输入连续字符的个数：")
    If charCount <= 1 Then
        MsgBox "请输入大于1的整数。"
        Exit Sub
    End If
    
        Selection.HomeKey Unit:=wdStory, Extend:=wdMove '回到文档的起点

    '定义变量
    Dim doc As Document
    Dim rng As Range
    Set doc = ActiveDocument
    Set rng = doc.Content
    
    
    Dim 第一次出现位置 As Long
    Dim 第二次出现位置 As Long
    Dim 找到, 一直找不到 As Boolean

    
    '遍历查找连续字符
    Do While rng.Find.Execute(findText:=String(charCount, "?"), MatchWildcards:=True)
        '获取连续字符文本
        Dim strText As String
        strText = rng.Text
        
        Call 查找(strText, False, True)

        第一次出现位置 = rng.Start
        
'            '将光标移动到文本末尾
'        rng.MoveEnd wdCharacter, Len(strText)
    
        '检查是否有重复的字符，并获取光标位置
        
        Call 查找(strText, False, True)
        找到 = Selection.Find.Found '若查找到则返回True
        一直找不到 = 找到 Or 一直找不到
        If 找到 Then
            第二次出现位置 = Selection.Start
            
            If 第二次出现位置 = 第一次出现位置 Then
                '不执行操作
            Else

                '弹窗提示重复的字符，并显示光标位置
                Dim 弹窗 As VbMsgBoxResult
                弹窗 = MsgBox("发现重复的" & charCount & "个连续字符：" & strText & vbCrLf & _
                                    "出现位置：" & 第一次出现位置 & " 和 " & 第二次出现位置 & vbCrLf & _
                                    "是否选中第一个重复字符？", vbYesNoCancel)
                '根据用户选择选中光标位置
                If 弹窗 = vbYes Then
                    Selection.SetRange Start:=第一次出现位置, End:=第一次出现位置 + charCount '选中
                    Exit Sub
    
                ElseIf 弹窗 = vbNo Then
                    '不执行操作
                ElseIf 弹窗 = vbCancel Then
                    Exit Sub
                End If
            End If
        End If
    Loop
    If 一直找不到 = 0 Then
        MsgBox ("文档没有重复的内容")
    Else
        MsgBox ("文档有重复的内容")

    End If
End Sub

Function 查找(文本, 通配符, 向下)

    Selection.Find.Font.Reset
    Selection.Find.ParagraphFormat.Reset
    With Selection.Find
        .Text = 文本
        .Forward = 向下
        .Wrap = wdFindContinue
        .MatchCase = True
        .MatchByte = True
        .MatchWildcards = 通配符
        .MatchWholeWord = False
        .MatchFuzzy = False
        .Replacement.Text = ""
    End With
   
    Selection.Find.Execute Replace:=wdReplaceNone
    Selection.Find.Replacement.Text = ""
End Function