如何用Word宏将3个及以上连续回车批量替换为2个直至无匹配？

需求：把文档里所有超过2个的连续回车（比如3个、5个、8个等）统一改成仅2个连续回车，直到没有多余的为止。

中文注释版宏（适配原逻辑） #

Sub 移除多余连续回车()
    Dim 循环计数器 As Integer
    ' 光标定位到文档开头
    Selection.HomeKey Unit:=wdStory
    
    With Selection.Find
        .ClearFormatting ' 清除查找格式规则
        .Text = "^p^p^p" ' 查找目标：3个连续段落标记（回车）
        .Replacement.Text = "^p^p" ' 替换为：2个连续段落标记
        .Forward = True ' 从当前位置往后查找
        .Wrap = wdFindContinue ' 查完文档末尾后自动从头继续找
        .Format = False ' 不匹配格式
        .MatchCase = False ' 不区分大小写
        .MatchWholeWord = False ' 不要求匹配整词
        .MatchKashida = False ' 忽略阿拉伯文Kashida字符
        .MatchDiacritics = False ' 忽略变音符号
        .MatchAlefHamza = False ' 忽略阿拉伯文Alef Hamza字符
        .MatchControl = False ' 忽略控制字符
        .MatchByte = False ' 不区分全角/半角
        .MatchAllWordForms = False ' 不匹配词形变化
        .MatchSoundsLike = False ' 不匹配发音相似词
        .MatchFuzzy = False ' 关闭模糊查找
        .MatchWildcards = False ' 不使用通配符
    End With

    ' 执行第一次查找
    Selection.Find.Execute
    ' 循环处理：找到就替换，直到没匹配项或循环1000次（防死循环）
    Do While Selection.Find.Found = True And 循环计数器 < 1000
        循环计数器 = 循环计数器 + 1
        ' 替换当前找到的内容
        Selection.Find.Execute Replace:=wdReplaceOne
        ' 回到文档开头，重新查找剩余匹配项
        Selection.HomeKey Unit:=wdStory
        ' 执行下一次查找
        Selection.Find.Execute
    Loop
End Sub

高效批量替换版（适合大文档） #

如果文档内容多，逐次替换效率低，可以用这个批量替换版本：每次把所有当前能找到的3个连续回车都替换成2个，循环到没有匹配项为止，速度更快。

Sub 批量移除多余连续回车()
    Dim 还有匹配项 As Boolean
    Do
        With ActiveDocument.Content.Find
            .ClearFormatting
            .Text = "^p^p^p"
            .Replacement.Text = "^p^p"
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchWildcards = False
            ' 一次性替换所有当前匹配的内容
            .Execute Replace:=wdReplaceAll
            ' 检查是否还有剩余匹配项
            .Execute
            还有匹配项 = .Found
        End With
    Loop While 还有匹配项 ' 直到没有多余回车为止
End Sub

使用方法：打开Word，按Alt+F11打开VBA编辑器，插入模块，把代码粘贴进去，运行宏即可。

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