VBA to insert reference page into MS word endnote - vba

Book endnotes often forgo superscript numbers for page numbers. E.g., instead of
Abe Lincoln was assassinated with a pistol.^33
:
33. A single-shot derringer pistol.
books by several authors write
Abe Lincoln was assassinated with a pistol.
:
Page 297. Abe Lincoln was shot single-shot derringer pistol.
Word doesn't have this feature, so I believe it would have to be a Macro. I came up with simple code below that loops through all of the endnotes and adds
"Page ???. "
before each endnote, but what does "???" need to be to correctly insert the page number in my manuscript that the citation's located on?
Sub RedefineExistingEndNotes()
Dim fn As Endnote
For Each fn In ActiveDocument.Endnotes
fn.Range.Paragraphs(1).Range.Font.Reset
fn.Range.Paragraphs(1).Range.Characters(1).InsertBefore "Page" & "???" & " - "
Next fn
End Sub

Try the below VBA code:
Sub InsertPageNumberForEndnotes()
Dim endNoteCount As Integer
Dim curPageNumber As Integer
If ActiveDocument.Endnotes.Count > 0 Then
For endNoteCount = 1 To ActiveDocument.Endnotes.Count
Selection.GoTo What:=wdGoToEndnote, Which:=wdGoToAbsolute, Count:=endNoteCount
curPageNumber = Selection.Information(wdActiveEndPageNumber)
ActiveDocument.Endnotes(endNoteCount).Range.Select
ActiveDocument.Application.Selection.Collapse (WdCollapseDirection.wdCollapseStart)
ActiveDocument.Application.Selection.Paragraphs(1).Range.Characters(1).InsertBefore "Page " & CStr(curPageNumber) & " - "
Next
End If
End Sub

An alternative might be to use PAGEREF fields and hide the endnote references, e.g.
Sub modifyEndNotes()
Const bookmarkText As String = "endnote"
Dim en As Word.Endnote
Dim rng As Word.Range
For Each en In ActiveDocument.Endnotes
en.Reference.Bookmarks.Add bookmarkText & en.Index
en.Reference.Font.Hidden = True
Set rng = en.Range
rng.Paragraphs(1).Range.Font.Hidden = True
rng.Collapse WdCollapseDirection.wdCollapseStart
rng.Text = "Page . "
rng.SetRange rng.End - 2, rng.End - 2
rng.Fields.Add rng, WdFieldType.wdFieldEmpty, "PAGEREF " & bookmarkText & en.Index & " \h", False
'if necessary...
'rng.Fields.Update
en.Range.Font.Hidden = False
Next
Set rng = Nothing
End Sub
For a second run, you'd need to remove and re-insert the text and fields you had added.
Unfortunately, a further look suggests that it would be difficult, if not impossible, to hide the endnote references (in the endnotes themselves) without hiding the paragraph marker at the end of the first endnote para, which means that all the endnotes will end up looking like a single messy note. So I deleted this Answer.
However, the OP thought the approach could be modified in a useful way so I have undeleted. I can't re-research it right away but some possibilities might be to replace every endnote mark by a bullet (as suggested by the OP) or perhaps even something as simple as a space or a "-".
For example, something like this (which also hides the references using a different technique)...
Sub modifyEndNotes2()
' this version also formats the endnotes under page headings
Const bookmarkText As String = "endnote"
Dim en As Word.Endnote
Dim f As Word.Field
Dim i As Integer
Dim rng As Word.Range
Dim strSavedPage As String
strSavedPage = ""
For Each en In ActiveDocument.Endnotes
en.Reference.Bookmarks.Add bookmarkText & en.Index
Set rng = en.Range
rng.Collapse WdCollapseDirection.wdCollapseStart
If CStr(en.Reference.Information(wdActiveEndPageNumber)) <> strSavedPage Then
strSavedPage = CStr(en.Reference.Information(wdActiveEndPageNumber))
rng.Text = "Page :-" & vbCr & " - "
rng.SetRange rng.End - 6, rng.End - 6
rng.Fields.Add rng, WdFieldType.wdFieldEmpty, "PAGEREF " & bookmarkText & en.Index & " \h", False
rng.Collapse WdCollapseDirection.wdCollapseEnd
Else
rng.Text = "- "
End If
Next
If ActiveDocument.Endnotes.Count > 1 Then
ActiveDocument.Styles(wdStyleEndnoteReference).Font.Hidden = True
Else
ActiveDocument.Styles(wdStyleEndnoteReference).Font.Hidden = False
End If
Set rng = Nothing
End Sub
In the above case, notice that there is only one link to each page, that formatting might be needed to make it obvious that it is a link, and so on.

Related

ActiveDocument.Printout issue

I have two word documents, source and target. My target document is pulling values from a table inside source document and putting those concatenated values stored inside a variable named ReportHeader into it's page header. I have used two For-Next loops, the outer loops takes care of designated rows inside source document and this loop begins at 6th row till count of total rows inside that table.
My inner loop named "For xPages = 1 To numPages" takes care of number of parges required for each Annexure that it finds inside the table and loops through found number of pages for a particular Annexure reference.
Below is reference screenshot of my table. Please ignore the fact the few preceding lines of my tableare not being shown here. My business begins with 6th row that shows Annexure A.
Everything works fine as long as I test values in Debug.print or Msgbox but when I sent these values for printing using ActiveDocument.PrintOut, I notice an abnormal printing behaviour. First few rows starting at row 6 of table are ignored and later not all the pages are sent to printing.
Any feedback from you guys would be much appreciated.
Thanks
Syed
Sub PrintMyHeaders()
Dim r As Range
Dim sourceDoc, jobNumber, AnnexureRaw, Annexure, ReportHeader As String
Dim numPages As Integer
Application.ScreenUpdating = False
jobNumber = InputBox("Enter job number")
sourceDoc = ActiveDocument.Name
ActiveDocument.Tables(3).Range.ListFormat.RemoveNumbers
Set r = ActiveDocument.Tables(3).Range
For Each doc In Documents
If doc.Name = "Template.doc" Then Found = True
Next doc
If Found <> True Then
Documents.Open FileName:="C:\Users\smi\Documents\Template.doc"
Else
Documents("Template.doc").Activate
End If
Documents(sourceDoc).Activate
For i = 6 To r.Rows.Count
AnnexureRaw = Replace(r.Rows(i).Cells(2).Range.Text, "", "")
Annexure = Replace(AnnexureRaw, Chr(13), "")
numPages = Val(r.Rows(i).Cells(3).Range.Text)
For xPages = 1 To numPages
counter = counter + 1
ReportHeader = "PAGE " & xPages & " OF " & numPages & vbCrLf _
& "OUR REF: TKU-" & jobNumber & "/2018" & vbCrLf _
& "ANNEXURE : " & Chr(34) & Annexure & Chr(34)
Documents("Template.doc").Activate
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.Font.Name = "Arial"
Selection.Font.Size = 8
Selection.Font.Bold = True
Selection.Text = ReportHeader
Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
Selection.ParagraphFormat.LineSpacing = 6
Selection.ParagraphFormat.Alignment = wdAlignParagraphRight
ActiveDocument.PrintOut
'Debug.Print ReportHeader & vbCrLf
Documents(sourceDoc).Activate
Next xPages
Next
Documents("template.doc").Activate
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Documents(sourceDoc).Activate
Application.ScreenUpdating = True
End Sub
When printing out documents in relatively quick succession, things can get "mixed up" if background printing is turned on. This is an option in Word:
File/Options/Advanced, section "Print"
In the object model, to turn it off programmatically you can use the following. If the user likes having it turned on, save the current setting, turn it off, then restore the setting at the end of the code:
Options.PrintBackground = False
Since speed of execution is a concern, your code can be optimized. The following suggestions can also help to make it more self-documenting. Note that I'm not testing, just writing from the top of my head, so I may make a typo or two...
Put Option Explicit at the top of your code modules. This will save you from frustrating error messages if you mistype a variable name.
Use declared objects throughout. Referring back to ActiveDocument each time is less efficient (VBA has to figure out which it is, every time. Also, the active document could change during code execution, which would mess things up.) Ditto for repeatedly requesting Tables(3).
If your concern when looping a collection is to ensure a certain member is present (a particular document, in your case) you can use Exit For to break off the loop before all members have been queried.
It's not necessary to activate a document in order to work with it in code. Once you have Document objects, that's all you need.
It's also not necessary to fiddle with the Views in order to work with a header or footer. I've deleted those lines.
I hope I've kept "everything straight"!
Option Explicit
Sub PrintMyHeaders()
Dim r As Range
Dim sourceDoc, jobNumber, AnnexureRaw, Annexure, ReportHeader As String
Dim numPages As Integer
Dim sourceTable as Word.Table, doc as Word.Document
Dim tDoc as Word.Document
Application.ScreenUpdating = False
jobNumber = InputBox("Enter job number")
Set sourceDoc = ActiveDocument
Set sourceTable = sourceDoc.Tables(3)
sourceTable.Range.ListFormat.RemoveNumbers
Set r = sourceTable.Range
For Each doc In Documents
If doc.Name = "Template.doc" Then
Found = True
Exit For
End If
Next doc
If Found <> True Then
Set tDoc = Documents.Open(FileName:="C:\Users\smi\Documents\Template.doc")
Else
Set tDoc = Documents("Template.doc")
End If
For i = 6 To r.Rows.Count
AnnexureRaw = Replace(r.Rows(i).Cells(2).Range.Text, "", "")
Annexure = Replace(AnnexureRaw, Chr(13), "")
numPages = Val(r.Rows(i).Cells(3).Range.Text)
For xPages = 1 To numPages
counter = counter + 1
ReportHeader = "PAGE " & xPages & " OF " & numPages & vbCrLf _
& "OUR REF: TKU-" & jobNumber & "/2018" & vbCrLf _
& "ANNEXURE : " & Chr(34) & Annexure & Chr(34)
Dim rngHeader as Word.Range
Set rngHeader = tDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range
rngHeader.Font.Name = "Arial"
rngHeader.Font.Size = 8
rngHeader.Font.Bold = True
rngHeader.Text = ReportHeader
rngHeader.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
rngHeader.ParagraphFormat.LineSpacing = 6
rngHeader.ParagraphFormat.Alignment = wdAlignParagraphRight
tDoc.PrintOut
'Debug.Print ReportHeader & vbCrLf
Next xPages
Next
tDoc.Close SaveChanges:=wdDoNotSaveChanges
Application.ScreenUpdating = True
End Sub

Word VBA: Error "The requested member of the collection does not exist" for a table cell that really does exist

I have a Word VBA script that adds some headings and a table to the current selection. I'm now trying to get it to pull information from the table below and put it under the correct heading. The end goal is to take the information out of table format for better navigation, because Word's outline doesn't recognize headings inside tables.
I've only gotten as far as putting table content into string variables before I get run-time error 5941: The requested member of the collection does not exist. The debugger goes to this line:
strChildren = rngSource.Tables(1).Cell(Row:=2, Column:=4).Range.Text
The table has far more than two rows and four columns. To make sure the member of the collection existed, I used another script to give me the row and column for the current selection:
Sub CellRowColumn()
'For the current selection, shows a message box with the cell row and column.
With Selection.Cells(1)
MsgBox ("Column = " & .ColumnIndex & vbCr & "Row = " & .RowIndex)
End With
End Sub
I ran this one in the cell I want to copy from, and it does show Row 2 & Column 4.
This is the code I'm using:
Sub ElementHeadings()
'With the current selection, adds the headings for each element in the
'Elements and Attribute List (Description, Parent(s), and Child(ren)) and
'a table for attributes, with 3 columns, headed "Attribute
'Name", "Attribute Required?" and "Attribute Content")
Dim rngSelection As Range
Dim rngTable As Range
Dim rngHeading As Range
Dim rngSource As Range
Dim strCaption As String
Dim lngCaptionLength As Long
Dim strDescr As String
Dim strParents As String
Dim strChildren As String
Dim strVol As String
Dim strUsedIn As String
Set rngSelection = Selection.Range
'msgBox (rngSelection.Text)
With rngSelection
.InsertAfter ("Description")
.InsertParagraphAfter
.Expand unit:=wdParagraph
.InsertAfter ("Parent(s)")
.InsertParagraphAfter
.Expand unit:=wdParagraph
.InsertAfter ("Child(ren)")
.InsertParagraphAfter
.Expand unit:=wdParagraph
.InsertParagraphAfter
.InsertParagraphAfter
Set rngTable = .Paragraphs(5).Range
.InsertAfter ("Volume & Chapter")
.InsertParagraphAfter
.Expand unit:=wdParagraph
.InsertAfter ("Used In")
.Expand unit:=wdParagraph
.Style = "Heading 4"
'MsgBox (rngSelection.Text)
End With
ActiveDocument.Tables.Add Range:=rngTable, NumRows:=3, NumColumns:=3
With rngTable
.Tables(1).Cell(1, 1).Range.Text = "Attribute Name"
.Tables(1).Cell(1, 2).Range.Text = "Attribute Required?"
.Tables(1).Cell(1, 3).Range.Text = "Attribute Content"
.Select
GenericMacros.TableFormat
.Move unit:=wdParagraph, Count:=-1
.Select
End With
rngSelection.Select
Set rngHeading = Selection.GoTo(what:=wdGoToHeading, Which:=wdGoToPrevious)
rngHeading.Expand unit:=wdParagraph
'MsgBox (rngHeading.Text)
rngTable.Select
strCaption = rngHeading.Text
lngCaptionLength = Len(strCaption)
strCaption = Left(strCaption, lngCaptionLength - 1)
Selection.InsertCaption Label:=wdCaptionTable, Title:=". <" _
& strCaption & "> Attribute Table"
rngSelection.Select
Set rngSource = Selection.GoTo(what:=wdGoToTable, Which:=wdGoToNext)
rngSource.Expand unit:=wdTable
strDescr = rngSource.Tables(1).Cell(Row:=2, Column:=2).Range.Text
strParents = rngSource.Tables(1).Cell(Row:=2, Column:=3).Range.Text
strChildren = rngSource.Tables(1).Cell(Row:=2, Column:=4).Range.Text
strVol = rngSource.Tables(1).Cell(Row:=2, Column:=8).Range.Text
strUsedIn = rngSource.Tables(1).Cell(Row:=2, Column:=9).Range.Text
MsgBox ("strDescr = " & strDescr & vbCr & "strParents = " & strParents & _
vbCr & "strChildren =" & strChildren & vbCr & "str3001Vol = " _
& str3001Vol & "strUsedIn = " & strUsedIn)
End Sub
(This may end up being a SuperUser question rather than a Stack Overflow question, if the problem is the document rather than my code. Previously, I was having trouble copying and pasting from the table (copying text but not getting the option to paste it above), but that's no longer happening. So if there's not an apparent issue with the code, maybe it's document corruption or some other Word weirdness.)
Update: My source range contained the table I had just created, rather than the one I wanted to pull from, so I fixed the Selection.Goto that was creating rngSource.
Good that you were able to track down where your code was failing. Working with the Selection object tends to be unreliable as it may not be where you're assuming (or where it was) when you wrote the code.
It's much better to work with Word's objects as whenever possible. For example, when you create a table, Dim a variable, then assign to it when you create the table. That gives you a "handle" on the table, no matter what kind of editing takes place before it, later:
Dim tbl as Word.Table
Set tbl = ActiveDocument.Tables.Add(Range:=rngTable, NumRows:=3, NumColumns:=3).
tbl.Cell(1,1).Range.Text = "Attribute Name"
'and so on...
To pick up an existing table you need to be able to identify it. If you're certain of the position, then:
Set tbl = ActiveDocument.Tables([index value])
If this is a "template" kind of document that you set up and re-use you can bookmark the table (select the table and insert a bookmark, or click in the first cell and insert a bookmark), then:
Set tbl = ActiveDocument.Bookmarks("BookmarkName").Range.Tables(1)
In a similar vein, you can replace this:
rngHeading.Expand unit:=wdParagraph
with the following if you want to work with the paragraph, explicitly:
Dim para as Word.Paragraph
Set para = rngHeading.Paragraphs(1)
It may also help you to know you can "collapse" a Range (similar to pressing the Arrow key with a selection) to its start or end point. This is useful if you want to add something, format it, then add something else that should have different formatting... (as an alternative to using InsertAfter consecutively then going back and formatting things differently).
I got something like OP, and after running below code:
Dim tbl As Word.Table: Set tbl = doc.Tables(2)
MsgBox tbl.Cell(1, 1).Range.Text
Which works on the idea that each table should have at least one cell in it,
did notice that I was accessing the wrong table too ;-)
So, you may use that first to get sure.

VBA find word and replace with a Hyperlink in Word 2010

I've a word document with some text. At some paragraphs I've words that I want to add the hyperlink to. Here's an example:
The book "When the sun goes up", ABC-1212321-DEF, have been released today.......
The "ABC-1212321-DEF" should be found and apply a hyperlink as follows: http://google.com/ABC-sometext-1212321-anothertext-DEF
All the strings in the document starts with "ABC-" and ends with "-DEF".
Thanks in advanced.
EDIT:
This is what I've got this far:
Sub InsertLinks()
Dim r As Range
Dim SearchString As String
Set r = ActiveDocument.Range
SearchString = "ABC-"
With r.Find
.MatchWildcards = True
Do While .Execute(findText:=SearchString, Forward:=True) = True
ActiveDocument.Hyperlinks.Add Anchor:=r, _
Address:=Replace(r.Text, " ", ""), _
SubAddress:="", ScreenTip:="", TextToDisplay:=r.Text
With r
.End = r.Hyperlinks(1).Range.End
.Collapse 0
End With
Loop
End With
End Sub
This now detects ABC- and add some random link. But need to get the number between ABC- and -DEF. The length is not the same.
SOLUTION
This is the code that solved my problem:
Sub InsertLinksTB()
Dim Rng As Range
Dim SearchString As String
Dim EndString As String
Dim Id As String
Dim Link As String
Set Rng = ActiveDocument.Range
SearchString = "ABC-"
EndString = "-DEF"
With Rng.Find
.MatchWildcards = True
Do While .Execute(findText:=SearchString, Forward:=False) = True
Rng.MoveStartUntil ("ABC-")
Rng.MoveEndUntil (" ")
'MsgBox (Rng.Text)
Id = Split(Split(Rng.Text, "ABC-")(1), "-DEF")(0)
'MsgBox (Id)
Link = "http://google.com/" & Id
ActiveDocument.Hyperlinks.Add Anchor:=Rng, _
Address:=Link, _
SubAddress:="", ScreenTip:="", TextToDisplay:=Rng.Text
Rng.Collapse wdCollapseStart
Loop
End With
End Sub
So if the text "ABC-1234-DEF" is found in the text, it will hyperlink this text with http://google.com/1234
Hope this is helpful for someone.

Using Multiple wildcard searches in Word 2007 with VBA

I have VBA code that runs through a document and identifies acronyms using wildcards and places them in a separate word document. Some of my writers don't always follow the proper style guides for acronyms so I'm running four different scripts to find all the possible acronyms. It's time consuming and I end up with multiple documents. Is there a method to run multiple searches from one script and have all the results placed in the separate document. Truth in Advertising: I found this script on the 'net, but I've been playing with it to attempt to make it do some other features. Adding current script:
Sub ExtractVariousValuesACRONYMSToNewDocument()
'The macro creates a new document,
'finds all words consisting of 2 or more uppercase letters
'in the active document and inserts the words
'in column 1 of a 3-column table in the new document
'Each acronym is added only once
'Use column 2 for definitions
'Page number of first occurrence is added by the macro in column 3
'Minor adjustments are made to the styles used
'You may need to change the style settings and table layout to fit your needs
'=========================
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Title = "Extract Acronyms to New Document"
'Show msg - stop if user does not click Yes
Msg = "This macro finds all words consisting of 2 or more " & _
"uppercase letters and extracts the words to a table " & _
"in a new document where you can add definitions." & vbCr & vbCr & _
"Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
.PageSetup.TopMargin = CentimetersToPoints(3)
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Acronyms extracted from: " & oDoc_Source.FullName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, NumRows:=2, NumColumns:=3)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Acronym"
.Cell(1, 2).Range.Text = "Definition"
.Cell(1, 3).Range.Text = "Page"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 70
.Columns(3).PreferredWidth = 10
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find strings consisting of 2 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[A-Z]{2" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Continue while found
strAcronym = oRange
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
'Insert page number in column 3
.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
End If
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
Application.ScreenUpdating = True
'If no acronyms found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No acronyms found."
oDoc_Target.Close savechanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
End Sub
The best solution would be one searching pattern for all cases. Word hasn't full regular expressions, it is not always possible. Write all four patterns, maybe there is a way for join them into one super-pattern.
The second possibility is running multiple times the same algorithm in one macro, something like this:
Sub Example()
Dim patterns As String
Dim pts() As String
'list of patterns for each run delimited by a delimiter - comma in this example
patterns = "first pattern, second pattern, and so on"
pts = Split(patterns, ",") 'the second parameter is a delimiter
Dim i As Integer
For i = 0 To UBound(pts)
'do your subroutine for each searching pattern
Next i
'save document with result
End Sub
For better answer give us more details, please.

Get paragraph no where txt is found, and move text to end of paragraph using Word 2010 vba

I am trying to use VBA to move a rich text clause ("strText"), which appears at the beginning of various paragraphs, to the end of each paragraph where the clause appears, and thereafter to underline strText.
I am a novice/hobbyist at vba programming, so please be gentle. I spent a few days on this before seeking help.
Problems with my attempted coding (which appears below):
I tried to assign to var "LparaNo" the number of the paragraph wherein the found text (strText) appears. But the number that "LparaNo" returns is totally off base.
If someone has a suggestion about how to get the right paragraph number, I'd appreciate it.
My intention is to set a range variable objRange_ParaHoldingText= ActiveDocument.Paragraphs(LparaNo).Range, i.e., a range that would reflect the paragraph in which the sought text was found.
I can't figure out how to move objRange01 ("strText", which is formatted text) to the end of the paragraph in which it appears.
Any suggestions would be much appreciated.
Thanks, Marc
Sub subFindTextAndMoveItToEndOfTheSameParagraphAndUnderlineIt_03()
' Code canniablized from http://stackoverflow.com/questions/11733766/how-to-search-for-text-and-check-for-underline-in-vba-for-word
Dim c As Range
Dim fnd As String
Dim strText As String
Dim objRange01 As Range
Dim objRange02 As Range
Dim objRange03 As Range
Dim LparaNo As Long
Dim strParazText As String
With ActiveDocument
strText = "Falsification 45 C.F.R. §" & Chr(160) & "6891(a)(2): "
' My objectives are: (1) to move strText from the beginning of various paragraphs, to the end of each paragraph where it appears,
' and thereafter, (2) to delete the ":" at the end of strText, and (3) to underline strText
fnd = strText
If fnd = "" Then Exit Sub
Set c = ActiveDocument.Content
c.Find.ClearFormatting
c.Find.Replacement.ClearFormatting
With c.Find
.Text = fnd
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
End With
c.Find.Execute
While c.Find.Found
c.Select ' I am trying to select the text that was found
Set objRange01 = c ' I am trying to set objRange01 = the text that was found, and selected
Selection.EndOf Unit:=wdParagraph, Extend:=wdExtend ' I am extending the selection to include the entire paragraph
Set objRange02 = Selection.Range 'The entire paragraph
Set objRange03 = ActiveDocument.Range(Start:=0, End:=Selection.End) ' I am trying to set objRange02 = all text from
' ' beginning of doc thru objRange01.text
LparaNo = objRange03.ComputeStatistics(wdStatisticParagraphs) + 1 ' I am trying to set LparaNo = the no. of paras in all
' ' text from beginning of doc thru the end of objRange02.
' ' Alas, the number generated for "LparaNo" is incorrect. The paragraph number generated for "LparaNo"
' ' is the number for a paragraph that appears 5 pages before objRange01.text
MsgBox "Paragraph # " & LparaNo & " [objRange01.Text = c = ] " & Chr(34) & objRange01.Text & Chr(34) & vbCrLf & _
vbCrLf & objRange02.Text & vbCrLf & vbCrLf & _
ActiveDocument.Paragraphs(LparaNo - 2).Range.Text & vbCrLf & _
ActiveDocument.Paragraphs(LparaNo - 1).Range.Text & vbCrLf & _
ActiveDocument.Paragraphs(LparaNo).Range.Text & vbCrLf ' & _
' ActiveDocument.Paragraphs(LparaNo + 1).Text & vbCrLf & _
' ActiveDocument.Paragraphs(LparaNo + 2).Range.Text & vbCrLf '& _
objRange01.Move Unit:=wdParagraph, Count:=1 ' I am trying unsuccessfully to move the selected text to the beginning
' ' of the next paragraph
objRange01.Move Unit:=wdCharacter, Count:=-1 ' I am trying unsuccessfully to move the selected text from the beginning
' ' of the next paragraph, to the end of the preceding paragraph, i.e.,
' ' to the end of the selected text's paragraph of origin.
c.Find.Execute
Wend ' While c.Find.Found
End With
End Sub 'subFindTextAndMoveItToEndOfTheSameParagraphAndUnderlineIt_03
Here is a suggestion that doesn't use Find. If you want to use Find, you'll need to loop, which can be tricky if there's any risk of finding the same text more than once. Instead, my solution loops through the Paragraphs collection. Does this get at what you're after?
Sub subFindTextAndMoveItToEndOfTheSameParagraphAndUnderlineIt_04()
Dim currDoc As Document
Set currDoc = ActiveDocument
Dim docRng As Range, currRng As Range, strRng As Range
Set docRng = ActiveDocument.Content
Dim currPara As Paragraph
Dim strText As String
strText = "Falsification 45 C.F.R. §" & Chr(160) & "6891(a)(2): "
Dim i As Long
' Set a counter to indicate the paragraph. This should be sufficient,
' unless your document is complicated in a way I cannot predict.
i = 0
' Loop through the paragraphs in the active document.
For Each currPara In docRng.Paragraphs
i = i + 1
' Check each paragraph for a match to strText. By using Mid you eliminate
' the chance of finding the string somewhere else in the text. This will work
' for different strText values.
If Mid(currPara.Range.Text, 1, Len(strText)) = strText Then
Set currRng = currDoc.Range(currPara.Range.Start, currPara.Range.End)
' Adds a space at the end of the paragraph. If you don't want the space,
' just delete the InsertAfter method. MoveEnd is used to bring the end of the
' range before the paragraph marker.
With currRng
.MoveEnd Unit:=wdCharacter, Count:=-1
.InsertAfter " "
End With
Set strRng = currDoc.Range(currRng.Start, currRng.Start + Len(strText))
' Set a range for the string, underline it, cut it, paste it at the end of the
' paragraph (again, before the paragraph marker), and select it. Note that moving
' a range doesn't move the text in it. Cut and paste does that.
With strRng
.Underline = wdUnderlineSingle
.Cut
.Move Unit:=wdParagraph, Count:=1
.Move Unit:=wdCharacter, Count:=-1
.Paste
.Select
End With
' Collapse the selection to the end of the text and backspace three times to
' remove the colon and two spaces. If these final characters are variable, you'll
' want something spiffier than this.
With Selection
.Collapse wdCollapseEnd
.TypeBackspace
.TypeBackspace
.TypeBackspace
End With
' Expand the range we've been using to hold the paragraph so that it includes the newly
' pasted text.
currRng.Expand wdParagraph
' I wasn't entirely sure what you wanted to convey in your message box. This displays
' the paragraph number and the new text of the paragraph.
MsgBox "Paragraph # " & i & " [currRng.Text = ] " & Chr(34) & currRng.Text
End If
Next currPara
End Sub