Acronym Search
When findRng.Find successfully discovers the search text within a field result (such as Table of Contents) the next .Execute begins at the start of the TOC rather than at the start position that had been set further down the document from the previous findRng.Find. This can be visually shown by choosing findRng.select. Per the findRng's Start and End properties, the selection should not include the start of the TOC, but it does AND this appears to be what the .Find method is also using because it becomes an Apple Corporate Headquarters address; i.e., One Infinite Loop. ;)
You can Watch the values of findRng.Start and .End which are as expected up until the .Execute statement near the bottom of the subroutine.
Unless anyone can fix the range reset issue I'd be happy just finding a way to quickly determine the .End location of the field that triggers wdInFieldResult yielding True and moving on with life.
Sub findAcronyms()
Dim findRng As Range, tempRng As Range
Dim oFld As Field
Dim findStr As String, acroStr As String
Dim acroTbl As Table
'################# test code
Dim testMode As Boolean
Dim testIdx As Long, testSize As Long, i As Long
testMode = True
testIdx = 0
testSize = 25
If testMode Then
ThisDocument.ShowRevisions = True
ThisDocument.TrackRevisions = True
End If
Quiet (Not testMode)
'#################
'set acroTbl to ThisDocument's Acronym table
Set findRng = ThisDocument.Content
findStr = "ACRONYMS"
With findRng.Find
.ClearFormatting
.Style = WdBuiltinStyle.wdStyleHeading1
.Text = findStr
.Forward = False
.Wrap = wdFindStop
.Format = False
.Execute
If Not .Found Then
MsgBox findStr & ": not found!", vbExclamation
Stop
Debug.Print "Debug the issue..."
Else
findRng.MoveStart wdTable
findRng.Expand wdTable
Set acroTbl = findRng.Tables(1)
End If
End With
'find occurrences of "(" and if closing parens "(" is within 7 characters then add to end of Acronym table
Set findRng = ThisDocument.Content
findStr = "("
With findRng.Find
.ClearFormatting
.Text = findStr
.Forward = True
.Wrap = wdFindStop
.Format = False
.Execute
Do While .Found 'until Find finds other than itself or EOD
'################# test code
If testMode Then
findRng.Select
Debug.Print findRng.Start
testIdx = testIdx + 1
If testIdx > testSize Then
Stop 'and Debug if necessary
Exit Sub
End If
End If
'################
i = findRng.MoveEndUntil(")", 7)
If i > 2 And Not findRng.Text Like Left(findStr & "#######", _
Len(findRng.Text)) Then
'check for pre-existence of acronym before adding to table
Set tempRng = ThisDocument.Range(acroTbl.Columns(1).Cells(2).Range.Start, _
acroTbl.Columns(1).Cells(acroTbl.Columns(1).Cells.Count).Range.End)
tempRng.Find.ClearFormatting
With tempRng.Find
.Text = Mid(findRng.Text, 2, i)
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
If Not .Found Then 'proceed with adding new acronym to table
With acroTbl.Rows
.Add
With .Last
.Cells(1).Range.Text = Mid(findRng.Text, 2, i)
i = findRng.Start
findRng.Collapse wdCollapseStart
findRng.MoveStart wdCharacter, -1
findRng.MoveStart wdWord, _
-.Cells(1).Range.Characters.Count
.Cells(2).Range.Text = Trim(findRng.Text)
findRng.Start = i + 1
Debug.Print .Cells(1).Range.Text, .Cells(2).Range.Text
End With
End With
End If
End With
Else: findRng.MoveStart wdWord 'skip over 2 letter acronyms
End If
If findRng.Information(wdInFieldResult) Then
findRng.MoveStart wdParagraph 'in lieu of a better solution I need to determine how to get out of the field result
ElseIf findRng.Information(wdWithInTable) Then
If findRng.InRange(findRng.Tables(1).Range.Cells(findRng.Tables(1).Range.Cells.Count).Range) Then 'test if in last cell
findRng.Expand wdTable
findRng.Collapse wdCollapseEnd
Else
findRng.MoveStart wdCell
End If
Else
findRng.MoveStart wdWord
End If
'################# test code
If testMode Then findRng.Select
'################
findRng.Collapse wdCollapseEnd
findRng.End = ThisDocument.Content.End
.Execute
Loop
End With
Stop
End Sub
Avoiding the broken behavior of Field.Result actually simplified the routine. Instead, employing Range.MoveStartUntil yielded more straightforward processing.
The findAcronyms routine searches thru ThisDocument.Content for each successive occurrence of open parens "(" until the end of document is reached. Upon finding an open parens, several filtering tests are run to eliminate undesirable results such as numeric strings and excessive acronym length (limited to 7 characters). If successful, the acronym is compared to the existing Acronym table for pre-existence before being appended with Track Changes enabled. Plural forms of acronyms (those with last character = "s") are reduced to singular form to again eliminate redundancies.
Finally, the newly appended acronyms are scrolled onto the screen and the User is prompted if they wish to accept and sort the table as is. This is followed by another prompt to perform a reverse check employing the checkAcronymUse routine. This Subr verifies whether each acronym in the table actually appears in the document. Useful when tailoring a document from an existing template with pre-populated Acronym table.
Option Explicit
Sub findAcronyms()
Dim findRng As Range, tempRng As Range
Dim findStr As String, acroStr As String
Dim acroTbl As Table
Dim sBool As Boolean
'################# test code
Dim testMode As Boolean
Dim testIdx As Long, testSize As Long, i As Long, j As Long
testMode = False
testIdx = 0
testSize = 100
Quiet (Not testMode)
'#################
'update all field codes and scroll to first occurrence of error
i = ThisDocument.Content.Fields.Update
If i > 0 Then
ThisDocument.ActiveWindow.ScrollIntoView ThisDocument.Range(i)
Stop 'and Debug as req'd
Exit Sub
End If
'set acroTbl to ThisDocument's Acronym table
Set findRng = ThisDocument.Content
findStr = "ACRONYMS"
With findRng.Find
.ClearFormatting
.Style = WdBuiltinStyle.wdStyleHeading1
.Text = findStr
.MatchWholeWord = False
.Forward = False
.Wrap = wdFindStop
.Format = False
.Execute
If Not .Found Then
MsgBox findStr & ": not found!", vbExclamation
Debug.Print "Debug the issue..."
Stop
Else
findRng.MoveStart wdTable
findRng.Expand wdTable
Set acroTbl = findRng.Tables(1)
End If
End With
' Main Loop: find occurrences of "(" and if closing parens ")" is within 7 characters then add to end of Acronym table
Set findRng = ThisDocument.Content
findStr = "("
With findRng
While .MoveStartUntil(findStr) > 0
sBool = False
'################# test code
If testMode Then
.Select
Debug.Print .Start
testIdx = testIdx + 1
If testIdx > testSize Then GoTo Finish
End If
'################
Set tempRng = .Duplicate
tempRng.End = .Start
i = tempRng.MoveEndUntil(")", 7) 'returns # of chars moved plus 1
If i > 3 Then 'filter out occurrences of single char parens; (?)
acroStr = Mid(tempRng.Text, 2, i)
If Right(acroStr, 1) = "s" Then
sBool = True
acroStr = Left(acroStr, Len(acroStr) - 1) 'exclude redundant plural form of acronym
End If
If Not acronymExists(acroTbl, acroStr) Then
addAcronym acroTbl, findRng.Duplicate, acroStr
If sBool Then 'remove plural "s" from acronym definition
With acroTbl.Rows.Last.Cells(2).Range
j = InStrRev(.Text, "s")
If j = Len(.Text) - 2 Then 'all cells contain two hidden characters after the end of text
ThisDocument.TrackRevisions = True
.Text = Mid(.Text, 1, j - 1)
ThisDocument.TrackRevisions = False
End If
End With
End If
End If
.MoveStart wdCharacter, i
Else: .MoveStart wdCharacter, 2
End If
Wend
End With
Finish:
ThisDocument.ActiveWindow.ScrollIntoView acroTbl.Range, False
If MsgBox("Accept and Sort Acronym table edits?", 65572, "Accept?") = 6 Then
With acroTbl
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, CaseSensitive:=True, LanguageID:=wdEnglishUS
.Range.Revisions.AcceptAll
End With
End If
If MsgBox("Verify Acronym table?", 65572, "Verify?") = 6 Then checkAcronymUse
Quiet (False)
End Sub
Sub checkAcronymUse()
Dim Rng As Range, findRng As Range
Dim srcDoc As Document
Dim myTblStyl As Style
Dim srcTbl As Table, tgtTbl As Table
Dim myRow As row
Dim r As Long
Dim findStr As String, srcAddr As String, srcDocName As String
Dim findBool As Boolean
'################# test code
Dim testMode As Boolean
Dim testSize As Long
testMode = False
testSize = 20
Quiet (Not testMode)
'#################
'set srcTbl to ThisDocument's Acronym table
Set Rng = ThisDocument.Content
findStr = "ACRONYMS"
With Rng.Find
.ClearFormatting
.Style = WdBuiltinStyle.wdStyleHeading1
.Text = findStr
.Forward = False
.Wrap = wdFindStop
.Format = False
.Execute
If Not .Found Then
MsgBox findStr & ": not found!", vbExclamation
Debug.Print "Debug the issue..."
Stop
Else
Rng.MoveStart wdTable
Rng.Expand wdTable
Set tgtTbl = Rng.Tables(1)
End If
End With
ThisDocument.ShowRevisions = True
ThisDocument.TrackRevisions = True
For Each myRow In tgtTbl.Rows
With myRow
If Not .HeadingFormat Then 'ignore column headings
findStr = Left(.Cells(1).Range.Text, .Cells(1).Range.Characters.Count - 1)
If Len(findStr) < 3 Then findStr = Left(.Cells(2).Range.Text, .Cells(2).Range.Characters.Count - 1)
Set findRng = ThisDocument.Content
findBool = False 'true if Find is outside of tgtTbl
With findRng.Find
.ClearFormatting
.MatchCase = True
.MatchWholeWord = False
.Text = findStr
.Forward = True
.Wrap = wdFindStop
.Format = False
.Execute
Do While .Found 'until Find finds other than itself or EOD
If findRng.InRange(tgtTbl.Range) Then
findRng.Expand wdTable
Else
findBool = True
Exit Do
End If
findRng.Collapse wdCollapseEnd
findRng.End = ThisDocument.Content.End
.Execute
Loop
End With
'################# test code
If testMode And .Index > testSize Then Exit For
'################
If Not findBool Then .Delete 'acronym not used; delete from table
End If
End With
Next myRow
'#################
If testMode Then Stop
'################
tgtTbl.Select
ThisDocument.TrackRevisions = False
Quiet (False)
End Sub
Function acronymExists(acroTbl As Table, str As String) As Boolean 'check for pre-existence of acronym to avoid duplication in acronym table
Dim tempRng As Range
If str Like Left("#######", Len(str)) Then 'filter out numerical strings
acronymExists = True
Else
Set tempRng = ThisDocument.Range(acroTbl.Columns(1).Cells(2).Range.Start, acroTbl.Columns(1).Cells(acroTbl.Columns(1).Cells.Count).Range.End)
tempRng.Find.ClearFormatting
With tempRng.Find
.Text = str
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
acronymExists = .Found
End With
End If
End Function
Sub addAcronym(acroTbl As Table, Rng As Range, str As String)
Dim ctr As Integer
ctr = Len(str)
ThisDocument.ShowRevisions = True
ThisDocument.TrackRevisions = True
With acroTbl.Rows
.Add
With .Last
.Cells(1).Range.Text = str
Rng.Collapse wdCollapseStart
'check words at, before, and just after ctr locations for simple correlation match to str
If Left(Rng.Previous(wdWord, ctr), 1) = Left(str, 1) Then
Rng.MoveStart wdWord, -ctr
ElseIf Left(Rng.Previous(wdWord, ctr + 1), 1) = Left(str, 1) Then
Rng.MoveStart wdWord, -ctr - 1
ElseIf Left(Rng.Previous(wdWord, ctr - 1), 1) = Left(str, 1) Then
Rng.MoveStart wdWord, -ctr + 1
Else: Rng.MoveStart wdWord, -ctr 'default, grab preceding words matching length of str
End If
.Cells(2).Range.Text = Trim(Rng.Text)
End With
End With
ThisDocument.TrackRevisions = False
End Sub
Sub Quiet(Optional bool As Boolean = True)
bool = Not bool
With Application
.ScreenUpdating = bool
.DisplayStatusBar = bool
End With
End Sub
Related
I want to change all the cross-reference text that are in middle of the text to lowercase, but not the ones at the beginning of a sentence.
The problem is that ActiveDocument.Paragraphs(row).Range.Text is going through the original text, not the ShowFieldCodes (or Alt+F9 view), which generates longer paragraphs and rows.
Sub SetLowerCase()
Dim bBig As Boolean
Dim txt As String, row As String, pos As Integer
ActiveWindow.View.ShowFieldCodes = True
Selection.HomeKey unit:=wdStory
With Selection.Find
.ClearFormatting
.Text = "^d REF"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = False
Do While .Execute
pos = Selection.Information(wdFirstCharacterColumnNumber)
row = Selection.Information(wdFirstCharacterLineNumber)
'The problem is that "ShowFieldCodes" generates longer paragraphs and more rows, which the next line does not take into account
txt = ActiveDocument.Paragraphs(row).Range.Text
If pos = 1 Then
bBig = True
ElseIf Mid(txt, pos - 2, 2) = ". " Then
bBig = True
ElseIf Mid(txt, pos - 1, 1) = "." Then
bBig = True
End If
If bBig = False Then
If Not Selection.Text Like "*Lower*" Then
With Selection
.MoveRight unit:=wdCharacter, Count:=1
.MoveLeft unit:=wdCharacter, Count:=1
.TypeText Text:="\*Lower "
.Fields.Update
End With
End If
Else
bBig = False
End If
Selection.Collapse wdCollapseEnd
Loop
End With
ActiveWindow.View.ShowFieldCodes = False
End Sub
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim Fld As Field, Rng As Range, StrRef As String
With ActiveDocument
.ActiveWindow.View.ShowFieldCodes = False
For Each Fld In .Range.Fields
With Fld
If .Type = wdFieldRef Then
Set Rng = .Result: StrRef = Split(Trim(.Code.Text), " ")(1)
Rng.MoveStart wdSentence, -1
Rng.MoveEnd wdSentence, 1
If Rng.Sentences.Count = 1 Then
.Code.Text = "REF " & StrRef & " \* Lower \h"
Else
.Code.Text = "REF " & StrRef & " \* FirstCap \h"
End If
End If
End With
Next
.Fields.Update
End With
Application.ScreenUpdating = True
End Sub
Whichever approach you take, you'll run up against VBA's ignorance of what a grammatical sentence is. For example, consider the following:
Mr. Smith spent $1,234.56 at Dr. John's Grocery Store, to buy: 10.25kg of potatoes; 10kg of avocados; and 15.1kg of Mrs. Green's Mt. Pleasant macadamia nuts.
For you and me, that would count as one sentence; for VBA it counts as 5...
I am using this code which is a batch find and replace macro. It finds and replaces the words in the document by reading the replacement words from another document (text.docx). This works absolutely fine when there are a handful of changes (i.e. less than 1 page). However, I hope to use this macro on documents that are 10-20 pages. When I use it, the word document just immediately crashes (starts not responding) and has to be forced to quit.
Does anyone have any tips on what can be done to prevent it from crashing? How can I modify the code to batch edit thousands of words? Code is below.
Thanks in advance!
Sub ReplaceFromTableList()
Dim oChanges As Document, oDoc As Document
Dim oTable As Table
Dim oRng As Range
Dim rFindText As Range, rReplacement As Range
Dim i As Long
Dim y As Integer
Dim sFname As String
Dim sAsk As String
sFname = "/Users/user/Desktop/test.docx"
Set oDoc = ActiveDocument
Set oChanges = Documents.Open(FileName:=sFname, Visible:=False)
Set oTable = oChanges.Tables(1)
y = 0
For i = 1 To oTable.Rows.Count
Set oRng = oDoc.Range
Set rFindText = oTable.Cell(i, 1).Range
rFindText.End = rFindText.End - 1
Set rReplacement = oTable.Cell(i, 2).Range
rReplacement.End = rReplacement.End - 1
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
Do While .Execute(findText:=rFindText, _
MatchWholeWord:=True, _
MatchWildcards:=False, _
Forward:=True, _
Wrap:=wdFindStop) = True
oRng.Select
oRng.FormattedText = rReplacement.FormattedText
y = y + 1
Loop
End With
Next i
oChanges.Close wdDoNotSaveChanges
MsgBox (y & " errors fixed")
End Sub
Your use of the FormattedText method to reproduce the formatting necessitates a time-consuming loop for each expression. The more the find expression occurs in the target document, the longer the process will take. Your unnecessary use of oRng.Select (which you don't then do anything with) makes it even slower - especially since you don't disable ScreenUpdating. The following macro avoids the need for the FormattedText looping:
Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim ThisDoc As Document, FRDoc As Document, Rng As Range, i As Long, j As Long, StrRep As String, StrCount As String
Set ThisDoc = ActiveDocument
Set FRDoc = Documents.Open("C:\Users\" & Environ("Username") & "\Downloads\FindReplaceTable.docx", _
ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
With ThisDoc.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindContinue
'Process each word from the F/R Table
For i = 1 To FRDoc.Tables(1).Rows.Count
Set Rng = FRDoc.Tables(1).Rows(i).Cells(1).Range
Rng.End = Rng.End - 1
.Text = Rng
StrCount = StrCount & vbCr & Rng.Text & ":" & vbTab & _
(Len(ThisDoc.Range.Text) - Len(Replace(ThisDoc.Range, Rng.Text, ""))) / Len(Rng.Text)
Set Rng = FRDoc.Tables(1).Rows(i).Cells(2).Range
Rng.End = Rng.End - 1
With Rng
If Len(.Text) > 0 Then
.Copy
StrRep = "^c"
Else
StrRep = ""
End If
End With
.Replacement.Text = StrRep
.Execute Replace:=wdReplaceAll
If i Mod 20 = 0 Then DoEvents
Next
End With
FRDoc.Close False
MsgBox "The following strings were replaced:" & StrCount
Set Rng = Nothing: Set FRDoc = Nothing: Set ThisDoc = Nothing
Application.ScreenUpdating = True
End Sub
Try this:
Sub FindReplaceAll()
Dim MyDialog As FileDialog, GetStr(1 To 100) As String
'100 files is the maximum applying this code
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Marriott International" 'Find What
.Replacement.Text = "Marriott" 'Replace With
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveWindow.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "operation end, please view", vbInformation
End Sub
The idea comes from here:
https://www.extendoffice.com/documents/word/1002-word-replace-multiple-files.html
I really have problems with this one. Imagine I have the word „stackoverflow“. At the end of the document there is a glossary. Now I need a macro that searches for all occurences of stackoverflow and replaces them with a hyperlink to the bookmark in the table. A reader still sees „stackoverflow“ but can click on it to jump to the Glossary. I can insert online links in „address“ field and think I need the subaddress field but do not know what to put there.. Thank you in advance!
Sub Convert_String()
Dim Word
Dim R As Range
Dim Tabellenanzahl
Dim T As Table
Dim Link As Hyperlink
Set R = ActiveDocument.Range
Tabellenanzahl = ActiveDocument.Tables.Count
Set T = ActiveDocument.Tables(Tabellenanzahl)
ActiveDocument.Bookmarks.Add "Anker", T.Range
For Z = 2 To T.Rows.Count
Set Wort = T.Cell(Z, 1)
With R.Find
.ClearFormatting
.Text = Word
.Forward = True
.Wrap = wdFindStop
End With
Do While R.Find.Execute
R.Hyperlinks.Add Anchor:=Selection, SubAddress:="Anker", TextToDisplay:="GoToGlossaryTest"
Loop
Next
End Sub
Try:
Sub GlossaryLinker()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range, HLnk As Hyperlink
Dim strFnd As String, BkMkNm As String, r As Long
With ActiveDocument
Set Tbl = .Tables(.Tables.Count)
For r = 2 To Tbl.Rows.Count
With Tbl.Cell(r, 1)
Set Rng = .Range
With Rng
.End = .End - 1
strFnd = Trim(Split(.Text, vbCr)(0))
BkMkNm = Replace(strFnd, " ", "_")
.Bookmarks.Add BkMkNm, .Duplicate
End With
End With
Set Rng = .Range(.Range.Start, Tbl.Range.Start)
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Text = strFnd
.Wrap = wdFindStop
.MatchWholeWord = True
.MatchWildcards = False
.MatchCase = True
.Execute
End With
Do While .Find.Found
If .InRange(Rng) = False Then Exit Do
Set HLnk = .Hyperlinks.Add(.Duplicate, , BkMkNm, , .Text)
.End = HLnk.Range.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
End With
Application.ScreenUpdating = True
End Sub
I am searching a long MS Word document for words that end in ly and highlighting them yellow.
However, certain words that end in ly are not adverbs (only, family) and I want to skip those.
How do I mod my code logic to do this:
If word=TargetList Then [If word=ExceptionList Then Skip ] Else [ highlight ]
Is a filter statement needed?
Sub FindAdverbs()
'
' FindAdverbs Macro
'
'
Dim range As range
Dim i As Long
Dim TargetList
TargetList = Array("ly") ' 'string to search for
ExceptionList = Array("family", "only") 'string of words to ignore
For i = 0 To UBound(TargetList)
Set range = ActiveDocument.range
With range.Find
.Text = TargetList(i)
.Format = True
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute(Forward:=True) = True
range.HighlightColorIndex = wdYellow
Loop
End With
Next
End Sub
Please try this code. Apart from what #Peh said about using reserved words for naming variables, I have avoided the use of variants. MS Word is about text and text is contained in strings. To use them is both easier and more efficient when manipulating texts.
Sub FindAdverbs()
' 03 Jun 2017
Dim Targets() As String
Dim Exceptions As String
Dim Rng As Range
Dim LastFound As Long, RngEnd As Long
Dim n As Long
Dim i As Long
Targets = Split("ly,lo", ",") 'string to search for
Exceptions = "family,only" 'string of words to ignore
For i = 0 To UBound(Targets)
Set Rng = ActiveDocument.Content
With Rng.Find
.Text = "*" & Targets(i)
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = True
.Format = False
.Forward = True
.MatchSoundsLike = False
.MatchAllWordForms = False
Do
.Execute
With Rng
If (.End <= LastFound) Then Exit Do
LastFound = .End
RngEnd = .End
.Collapse wdCollapseEnd
.MoveStart wdWord, -1
n = .MoveEndUntil(".,;:!?" & Chr(9) & Chr(10) & Chr(11) & Chr(12) & Chr(13) & Chr(32))
If (InStr(1, Exceptions, Trim(.Text), vbTextCompare) = 0) And (n = 1) Then
.HighlightColorIndex = wdYellow
End If
.SetRange RngEnd, RngEnd
End With
Loop While .Found
End With
Next i
End Sub
As another change I made which is worthy of your attention is in the line .Text = "*" & Targets(i). This will ensure that words containing "ly" in a position other than at the end will not be turned up by the search.
Every time the code found that word it would copy and paste text between a start and end position onto another sheet and roll to the next extract until it reached the end of the raw written extracts.
example would be
Start
Susan Had a lovely day today and made a lekker poo
end
Start1
John was feeling siiiccckkk so he took a poo too
end1
start2
Peter was in lots of trouble, so he bailed bro
end2
start3
Jacobus rektus van nel het n bal wat hy hey spiel met sy pieletjie
ending3
The desired outcome would be to find all extracts the words (Susan,Jacobus,Peter) and to copy them from "Start" to "End" as in the code and paste them one below the other in a new workbook.Thus John would not be included as I did not want to use him in my list of names.
The code is case sensitive, Could someone please help me create this list function, my attempt is below with NameToHighlight = Array("JASON", "JAMES ") , but the code is only returning the Jason extracts.
Sub CopyMsg_JarrydWard()
Dim DocA As Document
Dim DocB As Document
Dim para As Paragraph
Set DocA = ThisDocument
Set DocB = Documents.Add
Dim Rg As Range, RgMsg As Range
Dim StartWord As String, EndWord As String, NameToHighlight As Variant
Dim FoundName As Boolean
Set Rg = DocA.Content
Rg.Find.ClearFormatting
Rg.Find.Replacement.ClearFormatting
StartWord = "Start Message"
EndWord = "End Message"
'NameToHighlight = "DUNCAN HOWES"
'NameToHighlight = "DUNCAN HOWES,cat,pig,horse,man"
NameToHighlight = Array("JASON", "JAMES ") ' list of words in here
For i = LBound(NameToHighlight) To UBound(NameToHighlight)
With Rg.Find
'Set the parameters for your Find method
.Text = StartWord & "*" & EndWord
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
'Execute the Find
.Execute
'Loop through the results
While .Found
'Boolean to copy only message containing NameToHighlight
FoundName = False
'Keep Rg (result range for whole message) intact for later copy
Set RgMsg = Rg.Duplicate
'Highlight
'Start and End
DocA.Range(Start:=Rg.Start, End:=Rg.Start + Len(StartWord)).Bold = True
DocA.Range(Start:=Rg.End - Len(EndWord), End:=Rg.End).Bold = True
'NameToHighlight : here : Susan
With RgMsg.Find
'Set the parameters for your Find method
.Text = NameToHighlight(i)
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
'Execute the Find
.Execute
'Loop through the results
While .Found
RgMsg.Bold = True
FoundName = True
'Go to the next result for NameToHighlight
.Execute
Wend
End With 'RgMsg.Find
'Copy the whole message if NameToHighlight was found
If FoundName Then
Rg.Copy
DocB.Bookmarks("\EndOfDoc").Range.Text = "Page " & _
Rg.Characters.First.Information(wdActiveEndPageNumber) & vbCr
DocB.Bookmarks("\EndOfDoc").Range.Paste
DocB.Bookmarks("\EndOfDoc").Range.Text = vbCr & vbCr
End If
'Go to the next result for the message
.Execute
Wend
End With 'Rg.Find
Next i
End Sub
You were close, but you need to wrap the Find for the names only :
Sub CopyMsg_JarrydWard()
Dim DocA As Document
Dim DocB As Document
Dim para As Paragraph
Set DocA = ThisDocument
Set DocB = Documents.Add
Dim Rg As Range, RgMsg As Range
Dim StartWord As String, EndWord As String, NameToHighlight As Variant
Dim FoundName As Boolean
Set Rg = DocA.Content
Rg.Find.ClearFormatting
Rg.Find.Replacement.ClearFormatting
StartWord = "Start Message"
EndWord = "End Message"
'NameToHighlight = "DUNCAN HOWES"
'NameToHighlight = "DUNCAN HOWES,cat,pig,horse,man"
NameToHighlight = Array("JASON", "JAMES ") ' list of words in here
With Rg.Find
'Set the parameters for your Find method
.Text = StartWord & "*" & EndWord
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
'Execute the Find
.Execute
'Loop through the results
While .Found
'Boolean to copy only message containing NameToHighlight
FoundName = False
'Keep Rg (result range for whole message) intact for later copy
Set RgMsg = Rg.Duplicate
'Highlight
'Start and End
DocA.Range(Start:=Rg.Start, End:=Rg.Start + Len(StartWord)).Bold = True
DocA.Range(Start:=Rg.End - Len(EndWord), End:=Rg.End).Bold = True
For i = LBound(NameToHighlight) To UBound(NameToHighlight)
'NameToHighlight : here : Susan
With RgMsg.Find
'Set the parameters for your Find method
.Text = NameToHighlight(i)
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
'Execute the Find
.Execute
'Loop through the results
While .Found
RgMsg.Bold = True
FoundName = True
'Go to the next result for NameToHighlight
.Execute
Wend
End With 'RgMsg.Find
Next i
'Copy the whole message if NameToHighlight was found
If FoundName Then
Rg.Copy
DocB.Bookmarks("\EndOfDoc").Range.Text = "Page " & _
Rg.Characters.First.Information(wdActiveEndPageNumber) & vbCr
DocB.Bookmarks("\EndOfDoc").Range.Paste
DocB.Bookmarks("\EndOfDoc").Range.Text = vbCr & vbCr
End If
'Go to the next result for the message
.Execute
Wend
End With 'Rg.Find
End Sub