Word find and replace macro

[Night_Rain]

I'm stumped, and hope someone here might be able to help. I have been trying to cut out extraneous code written by the macro recorder, and I find my paired down version does two things I do not want:

1. It inserts a "0" just prior to all of the inserted page-breaks
2. It sometimes fails to replace all, only replacing the first instance

Here is the current code:

Sub Futures_and_Expedites()
'5/23/05: rewritten  bpg
    Application.ScreenUpdating = False
    With ActiveDocument.Content.Find
        .Execute FindText:="prior to^p", ReplaceWith:="prior to ", Replace:=wdReplaceAll
        .Execute FindText:="there is^p", ReplaceWith:="there is ", Replace:=wdReplaceAll
        .Execute FindText:="invoice^p", ReplaceWith:="invoice ", Replace:=wdReplaceAll
        .Execute FindText:="necessary^p", ReplaceWith:="necessary ", Replace:=wdReplaceAll
        .Execute FindText:="can^p", ReplaceWith:="can ", Replace:=wdReplaceAll
        .Execute FindText:="do not^p", ReplaceWith:="do not ", Replace:=wdReplaceAll
        .Execute FindText:="provide  status", ReplaceWith:="provide the status", Replace:=wdReplaceAll
        .Execute FindText:="^p^p^p^p", ReplaceWith:="^p", Replace:=wdReplaceAll
        .Execute FindText:="^p^p^p", ReplaceWith:="^p", Replace:=wdReplaceAll
        .Execute FindText:="Please^p", ReplaceWith:="Please ", Replace:=wdReplaceAll
        .Execute FindText:="required^p", ReplaceWith:="required ", Replace:=wdReplaceAll
        .Execute FindText:="these^p", ReplaceWith:="these ", Replace:=wdReplaceAll
        .Execute FindText:="delivery^p", ReplaceWith:="delivery.^p", Replace:=wdReplaceAll
        .Execute FindText:="Thank you,", ReplaceWith:="Thank you,^p^"
        .Execute FindText:="posted.^p", ReplaceWith:="posted.^p^p "
    End With
    With ActiveDocument.Content.Find
        .Execute FindText:="Contact: __________________", ReplaceWith:="", Replace:=wdReplaceAll
        .Execute FindText:=Date & "                        Future Delivery", ReplaceWith:="^m" _
            & Date & "                        Future Delivery", Replace:=wdReplaceAll
        .Execute FindText:=Date & "                      Purchasing", ReplaceWith:="^m" & Date _
            & "                      Purchasing", Replace:=wdReplaceAll
    End With
    Selection.HomeKey Unit:=wdStory
    Selection.Delete wdCharacter, 2
    With ActiveDocument.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = InchesToPoints(0.2)
        .BottomMargin = InchesToPoints(0.2)
        .LeftMargin = InchesToPoints(0.25)
        .RightMargin = InchesToPoints(0.25)
        .Gutter = InchesToPoints(0)
        .HeaderDistance = InchesToPoints(0.5)
        .FooterDistance = InchesToPoints(0.5)
        .SectionStart = wdSectionNewPage
    End With
    ActiveWindow.View.Type = wdPageView
End Sub

What is a clean why to code multiple replace alls?

 

[Night_Rain]

I've found something that seems to work a bit better, but I am still getting zeroes inserted before the page breaks. Any ideas?

Sub Expedite()
    Dim FindValue(1 To 9)
    Dim ReplaceValue(1 To 9)
    Dim i As Byte
    
    Application.ScreenUpdating = False
            
    'define values to find and replace
    FindValue(1) = "to^p"
    FindValue(2) = "is^p"
    FindValue(3) = "invoice^p"
    FindValue(4) = "necessary^p"
    FindValue(5) = "can^p"
    FindValue(6) = "not^p"
    FindValue(7) = "Contact: __________________"
    FindValue(8) = "^p^p^p^p"
    FindValue(9) = Date & "                      Purchasing"
    ReplaceValue(1) = "to "
    ReplaceValue(2) = "is "
    ReplaceValue(3) = "invoice "
    ReplaceValue(4) = "necessary "
    ReplaceValue(5) = "can "
    ReplaceValue(6) = "not "
    ReplaceValue(7) = ""
    ReplaceValue(8) = "^p"
    ReplaceValue(9) = "^m" & Date & "                      Purchasing"
    
    'run loop to execute find/replace
    For i = 1 To 9
        With Selection.Find
            .Text = FindValue(i)
            .Replacement.Text = ReplaceValue(i)
            .Execute replace:=wdReplaceAll
        End With
    Next 'i
    
    'make sure first page is selected
    Selection.HomeKey Unit:=wdStory
    'page setup
    With ActiveDocument.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = InchesToPoints(0.2)
        .BottomMargin = InchesToPoints(0.2)
        .LeftMargin = InchesToPoints(0.25)
        .RightMargin = InchesToPoints(0.25)
        .Gutter = InchesToPoints(0)
        .HeaderDistance = InchesToPoints(0.5)
        .FooterDistance = InchesToPoints(0.5)
        .SectionStart = wdSectionNewPage
    End With
    ActiveWindow.View.Type = wdPageView
End Sub

 

[Anne Troy]

Sorry, Night rain. I know it's an old thread, but I've looked and I see nothing in your code that should cause the zeroes.

 

[Night_Rain]

LOL... thanks. I've remained baffled, myself. I've found I can get rid of them using another find and replace searching for "0^m" and substituting "^m", so I have a workaround, at least. Their appearance seems a bit inconsistent, too. It is a very old version of Word. I am hoping it will just vanish when we get the 2003 upgrade rolled out.