VBA WORD：删除双段落标记

VBA WORD: Remove double paragraph marks

提问by JoshDG

Trying to move excessive paragraph gaps via this procedure.

试图通过此程序移动过多的段落间隙。

Sub RemoveGaps()
    wrdDoc.Content.Select

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting

    With Selection.Find
        .Text = "^13^13"
        .Replacement.Text = "^p"

        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = True
    End With

    Selection.Find.Execute Replace:=wdReplaceAll
    If Selection.Find.Found = True Then
        Call RemoveGaps
    End If

End Sub

After I run it the loop never ends and I end up with this kind of formation at the bottom of the document. Note that it does work for a bit then gets stuck.

在我运行它之后，循环永远不会结束，我最终在文档底部得到了这种形式。请注意，它确实工作了一段时间然后卡住了。

EDIT:I have two paragraph breaks at the end and they just replace with another two. I actually went manually to try to select and replace them ..and same thing, they just replace with an extra one for some reason. I don't know what that's about, perhaps its a different special character?

编辑：我最后有两个段落中断，他们只是用另外两个替换。实际上，我手动尝试选择和替换它们……同样的事情，出于某种原因，它们只是替换了一个额外的。我不知道那是什么，也许它是一个不同的特殊字符？

回答by Dick Kusleika

Sub RemoveGaps()

    Dim oFnd As Find

    Set oFnd = ThisDocument.Content.Find
    oFnd.ClearFormatting
    oFnd.Replacement.ClearFormatting

    With oFnd
        .Text = "^13^13"
        .Replacement.Text = "^p"

        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = True
    End With

    Do
        oFnd.Execute Replace:=wdReplaceAll
    Loop Until Not oFnd.Execute Or oFnd.Parent.End = ThisDocument.Content.End

End Sub

I have no idea why KazJaw's works - it still leaves two paragraph marks at the end, but Execute returns False. When I get to the last GoTo, I get this in the Immediate Window.

我不知道为什么 KazJaw 的作品 - 它最后仍然留下两个段落标记，但 Execute 返回 False。当我到达最后一个 GoTo 时，我会在立即窗口中看到它。

?selection.Find.Execute
False
?selection = string(2,chr$(13))
True

Why doesn't it find two carriage returns when that's all it is? Odd. Anyway, I don't like changing the selection or GoTo so I included my version. It quits when Find can't find anything or when it's at the end of the Document.

为什么它没有找到两个回车呢？奇怪的。无论如何，我不喜欢更改选择或转到，所以我包含了我的版本。当 Find 找不到任何内容或它位于文档末尾时，它会退出。

If you know the upper limit of how many paragraphs there will be in a row, you could do it a different way. For instance, if you know there are no more than 10 blank paragraphs, you could do this:

如果您知道一行中有多少个段落的上限，则可以采用不同的方式。例如，如果您知道不超过 10 个空白段落，您可以这样做：

Sub RemoveGaps2()

    Dim i As Long

    For i = 10 To 2 Step -1
        With ThisDocument.Content.Find
            .Text = "[^13]{" & i & ",}"
            .Replacement.Text = Chr$(13)
            .MatchWildcards = True
            .Execute , , , , , , , , , , wdReplaceAll
        End With
    Next i

End Sub

回答by Siddharth Rout

Try this

尝试这个

Sub RemoveGaps()
    wrdDoc.Content.Select

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting

    With Selection.Find
        .Text = "^p^p" '<~~~ See this
        .Replacement.Text = "^p"

        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False '<~~ Set this to false
    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    If Selection.Find.Execute = True Then
        Call RemoveGaps
    End If
End Sub

回答by Kazimierz Jawor

You don't need to fire whole sub but go back few lines like this:

您不需要触发整个子程序，而是像这样返回几行：

Sub RemoveGaps()
Dim wrdDoc As Document
Set wrdDoc = ActiveDocument
    wrdDoc.Content.Select

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting

    With Selection.Find
        'oryginal
        .Text = "^13^13"
        .Replacement.Text = "^p"
        .Forward = True

    End With

GoHere:
    Selection.Find.Execute Replace:=wdReplaceAll

    If Selection.Find.Execute = True Then
        GoTo GoHere
    End If

End Sub

I tested it and it works fine with my Word 2010.

我测试了它，它在我的 Word 2010 上运行良好。