Modify and paste clipboard text - vba

My goal is to:
Copy text in a PDF to the clipboard
In a single move, paste the text to MS Word while
Replacing all line breaks with a space
Matching the destination's formatting
I created a macro which replaces all line breaks with spaces in a document.
Selection.Find.Execute Replace:=wdReplaceAll
Selection.WholeStory
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = " "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
How to apply the replacement to the clipboard and then paste this replaced snippet?

I propose to do it this way:
remember current selection point where you would paste your clipboard data
paste what you have in clipboard
set ending point of pasted area
do replacement only for just pasted range of text.
The following solution based partially on the code from the question. What was necessary (for test) was commented.
Sub replacement_for_selection()
'Selection.Find.Execute Replace:=wdReplaceAll
'Selection.WholeStory
Dim rngFrom, rngTo
rngFrom = Selection.Start
Selection.PasteAndFormat (wdFormatOriginalFormatting)
rngTo = Selection.End
ActiveDocument.Range(rngFrom, rngTo).Select
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = " "
.Forward = False '!!!
.Wrap = wdFindStop '!!!
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute , , , , , , , , , , wdReplaceAll
End Sub

It worked for me too, but I improved it, adding a command to eliminate double spaces:
Sub KM()
'
' KM Macro
' Paste and eliminate line breaks and double spaces.
'
'Selection.Find.Execute Replace:=wdReplaceAll
'Selection.WholeStory
Dim rngFrom, rngTo
rngFrom = Selection.Start
Selection.PasteAndFormat (wdFormatOriginalFormatting)
rngTo = Selection.End
ActiveDocument.Range(rngFrom, rngTo).Select
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = " "
.Forward = False '!!!
.Wrap = wdFindStop '!!!
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute , , , , , , , , , , wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " "
.Replacement.Text = " "
.Forward = False
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Related

Creating a cloze test using Word VBA

As a beginner, I am trying to write a Word Macro that can automatically mark and convert one third of the words in an article to a cloze format. In the past, I have manually added equal signs before the desired word and then ran the following macro to complete the process. However, I am now attempting to automate this manual step by creating a new macro that will randomly add equal signs to the prefixes of the words in one-third of the selected range. After running this new macro, I plan to use the previous macro to finish the conversion to the cloze format. However, I am unsure how to set up the new macro to perform the marking and would appreciate any suggestions or guidance.
This is the conversion macro that is already done:
Sub Convert()
Application.ScreenUpdating = False
selection.HomeKey Unit:=wdStory 'init
Dim iCount, A, i As Long
Dim RPT, CHAR, WordRpt, Eventual As Integer
iCount = 0
WordRpt = 1
Eventual = 0
selection.Find.ClearFormatting 'A and I
selection.Find.Replacement.ClearFormatting
selection.HomeKey Unit:=wdStory
With ActiveDocument.Content.Find 'sum A
.text = "=a "
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
A = A + 1
Loop
End With
selection.HomeKey Unit:=wdStory
With ActiveDocument.Content.Find 'sum I
.text = "=i "
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
i = i + 1
Loop
End With
With selection.Find
.text = "=a "
.Replacement.text = "_ "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
selection.Find.Execute replace:=wdReplaceAll
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "=i "
.Replacement.text = "_ "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
selection.Find.Execute replace:=wdReplaceAll
With ActiveDocument.Content.Find 'sum equals
.text = "="
.Format = False
.Wrap = wdFindStop
Do While .Execute
iCount = iCount + 1
Loop
End With
While WordRpt <= iCount
WordRpt = WordRpt + 1
With selection.Find 'next equal
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Execute FindText:="="
selection.TypeBackspace
selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
CHAR = Len(selection) - 2
selection.MoveLeft Unit:=wdCharacter, Count:=1
selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
selection.Cut
selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
selection.PasteAndFormat (wdFormatOriginalFormatting)
UdsRpt = 1 'underscore
Do While UdsRpt <= CHAR
UdsRpt = UdsRpt + 1
selection.TypeText text:="_"
Loop
selection.TypeText text:=" "
End With
Wend
'
' patch comma
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ ,"
.Replacement.text = "__,"
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
'
' patch period
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ ."
.Replacement.text = "__."
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
'
' patch question mark
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ ?"
.Replacement.text = "__?"
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
'
' patch excalmation mark
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ !"
.Replacement.text = "__!"
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
'
' patch slash
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ /"
.Replacement.text = "__/"
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
'
' patch back slash
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ \"
.Replacement.text = "__\"
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
'
' patch colon
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ :"
.Replacement.text = "__:"
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
'
' patch semi colon
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ ;"
.Replacement.text = "__;"
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
'
' patch dash
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ –"
.Replacement.text = "__–"
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
'
' patch hyphen
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ -"
.Replacement.text = "__-"
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
'
' patch ellipsis
'
'
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
With selection.Find
.text = "_ …"
.Replacement.text = "__…"
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
End With
selection.Find.Execute replace:=wdReplaceAll
Eventual = A + i + iCount
MsgBox "Successfully converted" & Eventual & "words.", vbOKOnly, "Task Completed"
Application.ScreenUpdating = True
End Sub
This simple macro will insert an equals sign before words in a selection with a probability of 1 in 3.
Sub InsertEqualsSigns()
Randomize
Dim targetWord As Range
For Each targetWord In Selection.Range.Words()
targetWord.Select
Selection.MoveLeft Unit:=wdWord, Count:=1
If Rnd() < 1 / 3 Then
Selection.TypeText Text:="="
End If
Next
End Sub
Note that this is currently just set to add an equals sign, so change the text to insert "=a " or "=i " as preferred as I'm not sure the exact close formatting.

How to find and replace the Calibri font using VBA in MS Word

I am going to find the Calibri font in my document and replace with same content and same font (Calibri) with XML tag before and after <Cal></Cal>. I manually find and replacing each time. If i recorded this as a macro it not working.
Sub Caliberi_Font()
'
' Caliberi_Font Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = "<cal>^&</cal>"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
If i modify (or add) the line Selection.Find.Font.Name = "Calibri" to the macro then also not working
Sub Caliberi_Font()
'
' Caliberi_Font Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Font.Name = "Calibri"
With Selection.Find
.Text = ""
.Replacement.Text = "<cal>^&</cal>"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
My Input DOC file in Calibri font
My Input DOC file
My Output DOC file need to replace
My required output
Try:
Sub Calibri_Font()
Application.ScreenUpdating = False
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Name = "Calibri"
.Text = ""
.Replacement.Text = "<cal>^&</cal>"
.Forward = True
.Format = True
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True
End Sub

Giving multiple hyperlinks in MS-Word VBA based on own delimiter

I am new to VBA scripting. I am converting TeX file to Word document using GrindEq convertor. In this TeX file there have multiple \hrefcommands. Here content only coming in MS-Word file (i.e. https://doi.org/10.1016/0167-6423(87)90036-0). So far i am putting tag before and after for that content <LaTeX-href-http>https://doi.org/10.1016/0167-6423(87)90036-0</LaTeX-href-http> using python. By this content was producing with Tag in MS-Word file.
Similarly for converting to Small Caps font, converting to Monospace font, i have recorded the macro and modify as per my own needs and used.
Sub XXX_SmallCaps()
'
' XXX_SmallCaps Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.Font
.SmallCaps = True
.AllCaps = False
End With
With Selection.Find
.Text = "\<LaTeX-SmallCaps\>(*#)\</LaTeX-SmallCaps\>"
.Replacement.Text = "\1"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'
' XXX_Serif Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Size = 13
Selection.Find.Replacement.Font.Name = "Calibri"
With Selection.Find
.Text = "\<LaTeX-SerifFont\>(*#)\</LaTeX-SerifFont\>"
.Replacement.Text = "\1"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'
' XXX_MonoSpace
'
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Size = 12
Selection.Find.Replacement.Font.Name = "Courier New"
With Selection.Find
.Text = "\<LaTeX-MonospaceFont\>(*#)\</LaTeX-MonospaceFont\>"
.Replacement.Text = "\1"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
But how to give the Hyperlinks for the content in between the Tags <LaTeX-href-http>...</LaTeX-href-http> and <LaTeX-href-http> and </LaTeX-href-http> tags need to deleted using in VBA? Please refer the image for my DOC file.
For example (including cleaning up your other code):
Sub ReformatLaTeX()
Application.ScreenUpdating = False
Dim StrLnk As String
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True
.Replacement.Text = "\1"
.Replacement.Font.SmallCaps = True
.Text = "\<LaTeX-SmallCaps\>(*#)\</LaTeX-SmallCaps\>"
.Execute Replace:=wdReplaceAll
.Replacement.ClearFormatting
.Replacement.Font.Size = 13
.Replacement.Font.Name = "Calibri"
.Text = "\<LaTeX-SerifFont\>(*#)\</LaTeX-SerifFont\>"
.Execute Replace:=wdReplaceAll
.Replacement.Font.Size = 12
.Replacement.Font.Name = "Courier New"
.Text = "\<LaTeX-MonospaceFont\>(*#)\</LaTeX-MonospaceFont\>"
.Execute Replace:=wdReplaceAll
.Replacement.ClearFormatting
.Text = "\<LaTeX-href-http\>*#\<\/LaTeX-href-http\>"
.Replacement.Text = ""
.Wrap = wdFindStop
End With
Do While .Find.Execute
StrLnk = Split(Split(.Text, "</LaTeX-href-http>")(0), "<LaTeX-href-http>")(1)
.Hyperlinks.Add Anchor:=.Duplicate, Address:=StrLnk, TextToDisplay:=StrLnk
.Start = .Hyperlinks(1).Range.End
Loop
End With
Application.ScreenUpdating = True
End Sub

Is there a better way to take a list of addresses on word and seperate them down to single lines

Is there a better way to take a list of addresses on word and separate them down to single line.
I have about 200 addresses to work through and they have to go from this
To this
So it can end up being copied like this into excel
The code I am currently Using is as follows but all that does is uses the replace function to change special formatting characters.
It isn't the cleanest method and if for instance some hasnt used a paragragh break but just a new line then it won't work.
Sub AddressMacro()
'
' AddressMacro Macro
'
'
ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View. _
ShowAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p^p"
.Replacement.Text = "^l"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Selection.Find.Execute Replace:=wdReplaceAll
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = "^t"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Selection.Find.Execute Replace:=wdReplaceAll
End With
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^i"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Selection.Find.Execute Replace:=wdReplaceAll
End With
ActiveWindow.ActivePane.View.ShowAll = Not ActiveWindow.ActivePane.View. _
ShowAll
End Sub
How about: (replaces)
'1) Chr$(9) to Chr$(32)
'2) Chr$(10) to Chr$(13)
'3) Chr$(11) to Chr$(13)
'4) Chr$(13) & Chr$(13) to Chr$(13)
'5) repeat 4 until there are none
'6) Chr$(13) to Chr$(9)
'7) Chr$(133) to Chr$(13)
EDIT: Here's what I had in mind: (It's a lot -- there's a bottomless pit of information on Word VBA -- http://word.mvps.org/faqs/MacrosVBA/index.htm -- good luck.)
Option Explicit
Sub main()
Call doReplace(Chr$(9), Chr$(32))
Call doReplace(Chr$(10), Chr$(13))
Call doReplace(Chr$(11), Chr$(13))
Do While doReplace(Chr$(13) & Chr$(13), Chr$(13))
Loop
Call doReplace(Chr$(13), Chr$(9))
Call doReplace(Chr$(133), Chr$(13))
End Sub
Function doReplace(OldText$, NewText$) As Boolean
With ThisDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = OldText
.Replacement.Text = NewText
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
doReplace = .Execute(Replace:=wdReplaceAll)
End With
End Function

Word 2010 VBA Replace within a highlighted range

The following code works, but it performs everything on the entire document. I'd like to highlight a block of text, then when I run the macro only have it work on the highlighted text. How do I do that? Thanks...
Sub DoCodeNumberStyle(numchars As String)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "(^13)([0-9]{" + numchars + "}) "
.Replacement.Text = "\1###\2$$$ "
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("CodeNumber")
With Selection.Find
.Text = "###([0-9]{" + numchars + "})$$$"
.Replacement.Text = "\1"
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub CodeNumberStyle()
DoCodeNumberStyle ("1")
DoCodeNumberStyle ("2")
End Sub
PostScript:
One additional thing I've discovered: if you do more than one find on a Selection, the first find loses/changes the Selection, so the others are no longer bounded by the original Selection (and a wdReplaceAll will continue to the end of the document). To fix this, capture the Selection into a Range. Here's the final version of my method, which now does everything I need, is restricted to the original highlighted selection (even with 3 find-and-replacements), and has also been minimized, code-wise:
Sub AAACodeNumberStyleHighlightedSelection()
With Selection.Range.Find
.ClearFormatting
.Style = ActiveDocument.Styles("Code")
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
' First line:
.Text = "1 //"
.Replacement.Text = "###1$$$ //"
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
' Rest of lines:
.Text = "(^13)([0-9]{1,2}) "
.Replacement.Text = "\1###\2$$$ "
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
' Now style the line numbers:
.Text = "###([0-9]{1,2})$$$"
.Replacement.Text = "\1"
.Replacement.Style = ActiveDocument.Styles("CodeNumber")
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
End Sub
Change .Wrap to wdFindStop and this should work for you. I think this might be a minor Word bug; the documentation says that the Wrap value
sets what happens if the search begins at a point other than the beginning of the document and the end of the document is reached (or vice versa if Forward is set to False) or if the search text isn't found in the specified selection or range.
But it seems like it forces the Find to go to the end of the document rather than taking the selection into account. Anyway, there's no need for wdFindAsk if you only plan to run this on selections.
I, too, found that even when beginning a FIND loop on a range, the range is redefined by FIND, and so continuous loop on .execute goes beyond the original range to the end of the document. wdFindStop stops only at the end of the document, not at the end of the original range.
So, I inserted an IF statement:
do while .find.found
...
If .find.parent.InRange(doc.Bookmarks("BODY").Range) = False Then Exit Do
...
.execute
loop
Set myRange = Selection.Range
myRange.Select
With Selection.Find
.Text = "Apple"
.Replacement.Text = "Banana"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
'.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
myRange.Select
With Selection.Find
.Text = "red"
.Replacement.Text = "yellow"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
'.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll