Word 2010 VBA Macro: loop to end of document - vba

I have recorded a simple macro to find the word "Quantity", go to the end of that line and insert a carriage return. I need to repeat it to the end of the document and quit, or else I'll have an infinite loop.
The code:
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Quantity:"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.EndKey Unit:=wdLine
Selection.TypeParagraph


Change you code to this, note the use of wdFindStop.
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Quantity:"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
do while Selection.Find.Execute = true
Selection.EndKey Unit:=wdLine
Selection.TypeParagraph
loop
If you have the type of documents this can fail on you can use the Selection.Start by
replacing the loop like this:
Dim lastPos As Long
lastPos = -1
Do While Selection.Find.Execute = True
If lastPos > Selection.Start Then Exit Do
Selection.EndKey Unit:=wdLine
Selection.TypeParagraph
Loop


Add Selection.Find.Execute Replace:=wdReplaceAll after your End with

Related

I want to highlight a word if it is not followed by another specific word using VB

So I'm a total newbie when it comes to using VB. I am trying to highlight a word when it is not followed by another specific word within the next two words. I tried the following code but it seems to just the first word. Many thanks in advance.
Sub fek()
'
'
'
'
Selection.Find.ClearFormatting
With Selection.Find
.Text = "n."
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Found = True Then
With Selection.Range
.MoveStart wdWord, 2
End With
With Selection.Find
.Text = "fek"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End If
If Selection.Find.Found = False Then
Selection.Range.HighlightColorIndex = wdYellow
End If
End Sub

The code below should do what you want. You need to bear in mind that what Word defines as a Word can be different to what a human would, e.g. an IP address is counted as 7 words!
Sub fek()
Dim findRange As Range
Dim nextWords As Range
Set findRange = ActiveDocument.Content
With findRange.Find
.ClearFormatting
.Text = "n."
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute = True
'findRange is now the range of the match so set nextWords to the 2 next words
Set nextWords = findRange.Next(wdWord)
nextWords.MoveEnd wdWord, 3
'look for the specific text in the next two words
If InStr(nextWords.Text, "fek") = 0 Then findRange.HighlightColorIndex = wdYellow
'collapse and move findRange to the end of the match
findRange.Collapse wdCollapseEnd
findRange.Move wdWord, 4
Loop
End With
End Sub

The following would probably be significantly faster if there are many 'n.' strings in the document:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long
i = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdYellow
With ActiveDocument.Range
With .Find
.Forward = True
.Format = False
.MatchCase = False
.Wrap = wdFindContinue
.MatchWildcards = True
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.Text = "n."
.Replacement.Text = "^&"
.Execute Replace:=wdReplaceAll
.Replacement.Highlight = False
.Text = "n.[^s ]#fek"
.Execute Replace:=wdReplaceAll
.Text = "n.[^s ]#[!^s ]#fek"
.Execute Replace:=wdReplaceAll
.Text = "n.[^s ]<[!^s ]#>[^s ]#fek"
.Execute Replace:=wdReplaceAll
.Text = "n.[^s ]<[!^s ]#>[^s ]#[!^s ]#fek"
.Execute Replace:=wdReplaceAll
End With
End With
Options.DefaultHighlightColorIndex = i
Application.ScreenUpdating = True
End Sub

How to search for and highlight an array of "ChrW(n)" Asian font characters using VBA rather than listing them out

I use a colleague-made macro which scans a document and highlights specified Asian font characters (such as a full stop [ChrW(65294)], an apostrophe [ChrW(65287)]). It works fine, and does exactly what I need it to (highlight Asian font characters) but because it was cobbled together and added to over time, it's incredibly long and not very elegant.
I sometimes need to share it with other colleagues and it's cumbersome having to use such a long macro.
Here's a sample of the code (the actual one is hundreds of lines long):
Sub HighlightAsianCharacters
Selection.Find.ClearFormatting
With Selection.Find
'full stop
.Text = ChrW(65294)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.Find.Execute
While Selection.Find.Found
Options.DefaultHighlightColorIndex = wdTurquoise
Selection.range.HighlightColorIndex = wdTurquoise
Selection.Find.Execute
Wend
Selection.Find.ClearFormatting
With Selection.Find
'apostrophe
.Text = ChrW(65287)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.Find.Execute
While Selection.Find.Found
Options.DefaultHighlightColorIndex = wdTurquoise
Selection.range.HighlightColorIndex = wdTurquoise
Selection.Find.Execute
Wend
End Sub
Does anyone know how to put the character codes into an array (for example) so the macro doesn't have to be pages and pages in length?
Many thanks in advance for any help!

Why not simply create a subroutine that replaces one of these characters and pass the character as parameter. Then call the routine for each character you want to handle.
Sub HighlightAllAsianCharacters
HighlightAsianCharacter ChrW(65294)
HighlightAsianCharacter ChrW(65287)
(...)
End Sub
Sub HighlightAsianCharacter(asianChr as string)
Selection.Find.ClearFormatting
With Selection.Find
.Text = asianChr
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
Selection.Find.Execute
While Selection.Find.Found
Options.DefaultHighlightColorIndex = wdTurquoise
Selection.range.HighlightColorIndex = wdTurquoise
Selection.Find.Execute
Wend
End Sub
Of course you could collect all characters in an array or collection first and then loop over it, but I don't really see a point in doing so.

Macro creates multiple page breaks instead of just one

I created a macro that finds an instance of style H1 followed by style H2, and inserts a page break between them. And reiterates this till it gets to the end of the document.
However, the macro adds multiple page breaks (maybe 50 of them) instead of just one.
what did I do wrong and how to correct this?
The code:
Sub Force_page_break()
'
' Force_page_break Macro
'
'
Dim Eloop As Integer
Eloop = 1
Selection.HomeKey Unit:=wdStory
Do While Eloop = 1
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Heading 1")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
If Selection.Find.Execute = False Then
Eloop = 0
Exit Do
End If
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Heading 2")
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.InsertBreak Type:=wdPageBreak
Loop
ActiveDocument.Save
End Sub

Maybe you can add a line
Eloop = Eloop + 1
after the line
Selection.InsertBreak Type:=wdPageBreak
to get out of the loop?

Modify and paste clipboard text

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

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