I found this code online to search and highlight multiple words. It takes roughly about 10 min to run it on a 15 page document. I was wondering if it could be made to run any faster.
Sub HighlightMultipleWords()
Dim Word As Range
Dim WordCollection(2) As String
Dim Words As Variant
'Define list.
'If you add or delete, change value above in Dim statement.
WordCollection(0) = "word1"
WordCollection(1) = "word2"
WordCollection(2) = "word3"
'Set highlight color.
Options.DefaultHighlightColorIndex = wdYellow
'Clear existing formatting and settings in Find feature.
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
'Set highlight to replace setting.
Selection.Find.Replacement.Highlight = True
'Cycle through document and find words in collection.
'Highlight words when found.
For Each Word In ActiveDocument.Words
For Each Words In WordCollection
With Selection.Find
.Text = Words
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
Next
End Sub
The comments are all correct here, you only need to run the find and replace once per item in your list, you are running it multiple times by the amount of words in the document.
Option Explicit
Sub HighlightMultipleWords()
Dim AryWords(2) As String
Dim VntStore As Variant
'Define list.
'If you add or delete, change value above in Dim statement.
AryWords(0) = "word1"
AryWords(1) = "word2"
AryWords(2) = "word3"
'Set highlight color.
Options.DefaultHighlightColorIndex = wdYellow
With Selection.Find
'Clear existing formatting and settings in Find feature.
.ClearFormatting
.Replacement.ClearFormatting
'Set highlight to replace setting.
Selection.Find.Replacement.Highlight = True
'Process the array
For Each VntStore In AryWords
.Execute FindText:=VntStore, _
MatchCase:=False, _
MatchWholeWord:=False, _
MatchWildcards:=False, _
MatchSoundsLike:=False, _
MatchAllWordForms:=False, _
Forward:=True, _
Wrap:=wdFindContinue, _
Format:=True, _
Replace:=wdReplaceAll
Next
End With
End Sub
Related
I am trying to create a Word macro that will:
Search for a specific word (i.e. "see")
Select the entire paragraph where that word appears
Make the whole paragraph a different style (i.e. make it all red text)
Do the same thing with a second word (i.e. "blacklist")
Select that whole paragraph and apply a different style (i.e. again, make the paragraph red text)
Copy all paragraphs with the red text style and paste them in to a new word document
Unfortunately, I'm no VBA expert and I'm trying to cobble things together from what I can find online. I have found a great example that will select to the start of the paragraph, but I can't seem to figure out how to select the entire paragraph. Any help is appreciated!
** Sorry - here is the code I currently have. It will find all instances of the word "see" and selects to the start of the paragraph, then changes the color to red... but that's as far as I've gotten, as I am stuck on trying to figure out how to get it to select to the end of the paragraph.
Sub TestOne()
'
' TestOne Macro
'
'
If MsgBox(Prompt:="Would you like to update selected paragraph styles?", Buttons:=vbYesNo + vbQuestion, _
Title:="Format MD Report") = vbNo Then
Exit Sub
End If
Application.ScreenUpdating = False
Dim i As Long
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "see"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = False
End With
Do While .Find.Execute
i = i + 1
.Start = .Paragraphs.First.Range.Start
.Font.Color = wdColorRed
.Start = .Paragraphs.First.Range.End
Loop
End With
Application.ScreenUpdating = True
MsgBox i & " instances processed."
End Sub
For example, without needing to create a second document:
Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String
StrFnd = "see|blacklist"
With ActiveDocument.Range
.Font.Hidden = True
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Text = "^&"
.Font.Hidden = True
.Replacement.Font.Hidden = False
.Format = True
.Forward = True
.MatchWildcards = True
.Wrap = wdFindContinue
For i = 0 To UBound(Split(StrFnd, "|"))
.Text = "[!^13]#" & Split(StrFnd, "|")(i) & "*^13"
.Execute Replace:=wdReplaceAll
Next
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
You could, of course, add a line of code before the final 'End With' to save the document with a new name.
To select the entire paragraph, following the line
.Start = .Paragraphs.First.Range.Start
add
.End = .Paragraphs.First.Range.End
... then to match only whole words, after
.MatchWildcards = False
add
.MatchWholeWord = True
And to run the code for multiple words you should add a parameter to your Sub eg
Sub TestOne(theWord As String)
then replace
.Text = "see"
with
.Text = theWord
And to run your code for each required word, add a Sub such as
Sub RunMe()
TestOne "see"
TestOne "blacklist"
End Sub
... optionally, move your MsgBoxes into RunMe()
The below VBA Word macro is run after selecting several paragraphs or for this example all of them.
I attach a sample .rtf file on which to run the macro.
The biblical references at the start of the paragraphs all get a pair around them, except the one that has a hyperlink. Is my macro at fault or is this an issue with Word 2010. As a secondary point it would be helpful to know if this works on Office 365
(I have tried the same, on LibreOffice and it does match even if word is hyperlinked one
(^)([A-Z123I ]{1,3}[^ ]{1,15} )([0-9]{1,3}:[0-9-\–]{1,7})
$1$2$3$2$3
So please don't suggest that I have not made any effort to find if this should work, or that I have not tried different settings. It would have been more helpful for someone to post that it did not work for them to at least show they had taken the time to download the macro test file and actually do a test)
Private Sub RelRefWithBibleName_Click()
InSelection = False
If selection.Type = wdSelectionIP Then InSelection = True
If InSelection = True Then
MsgBox ("select some text")
Exit Sub
End If
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
selection.Find.Replacement.Font.Reset
Application.ScreenUpdating = False
With selection
'Added this to make selection go beyond the start of the selected paragraph
'so that the detection would work
selection.MoveStartUntil Cset:=wdCharacter, Count:=wdBackward
strFindText = "([^13])([A-Z123I ]{1,3}[! ]{1,15} )([0-9]{1,3}:[0-9\-\–]{1,7})"
strReplaceText = "\1<ref>\2\3</ref>\2\3"
End With
With selection.Find
.MatchWildcards = True
.ClearFormatting
.Replacement.ClearFormatting
.text = strFindText
.Replacement.text = strReplaceText
.Format = False
.MatchWholeWord = True
.Forward = True
.Wrap = wdFindStop
End With
selection.Find.Execute Replace:=wdReplaceAll
selection.Shrink
selection.Move
Application.ScreenUpdating = True
selection.Find.ClearFormatting
selection.Find.Replacement.ClearFormatting
End Sub
Looping through the hyperlinks collection is no big deal. That said, there is another way:
Sub Demo()
Application.ScreenUpdating = False
Dim RngFnd As Range, StrTxt As String
With Selection
Set RngFnd = .Range
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "[A-Z1-3 ]{1,3}[! \<\>]{1,15} [0-9]{1,3}:[0-9\-\?]{1,7}"
.Replacement.Text = ""
.Forward = True
.Format = False
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
If .InRange(RngFnd) Then
If .Paragraphs.Count > 1 Then .Start = .Paragraphs(1).Range.End
If .Start = .Paragraphs(1).Range.Start Then
StrTxt = .Text
.InsertBefore "<ref>" & StrTxt & "</ref>"
.Font.Bold = False
.Start = .End - Len(StrTxt)
.Font.Bold = True
End If
If .Hyperlinks.Count > 0 Then
If .Hyperlinks(1).Range.Start = .Paragraphs(1).Range.Start Then
With .Hyperlinks(1).Range
StrTxt = .Text
.InsertBefore "<ref>" & StrTxt & "</ref>"
.Font.Bold = False
.Start = .End - Len(StrTxt)
.Font.Bold = True
End With
End If
End If
Else
Exit Do
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
RngFnd.Select
Application.ScreenUpdating = True
End Sub
There is nothing wrong with your Find/Replace expressions, though they could be simplified:
strFindText = "([^13])([A-Z1-3 ]{1,3}[! ]{1,15} [0-9]{1,3}:[0-9\-\–]{1,7})"
strReplaceText = "\1<ref>\2</ref>\2"
The Word version is of no consequence. For hyperlinks, you could loop through the hyperlinks collection and, if applicable, testing the display text, before inserting the tags either side of them.
UPDATE: Following the suggestion of Cindy below, I used the InRange function. My function iterates fine through the Find operation. But the function is failing to return FALSE when the selection is outside the named range. See "FAILING HERE" below. Thanks.
Using Visual Basic, I need to validate whether the selection location in a Word document is within a named range. Many years ago, I used this code to do that:
ActiveDocument.Bookmarks("typdef").Select
While ((WordBasic.CmpBookmarks("\Sel", "typedef") = 8 _
Or WordBasic.CmpBookmarks("\Sel", "typedef") = 6 _
Or WordBasic.CmpBookmarks("\Sel", "typedef") = 10) _
And leaveloop <> 1
...
If WordBasic.CmpBookmarks("\Sel", "\EndOfDoc") = 0 Then
leaveloop = 1
End If
Wend
Here's the updated function I wrote:
Function FormatSpecHeadReturn(strStyle)
Dim rngBookmark As Word.Range
Dim rngSelection As Word.Range
Set rngBookmark = ActiveDocument.Bookmarks("SpecBodyPairRange").Range
Set rngSelection = Selection.Range
var = rngSelection.InRange(rngBookmark)
Debug.Print var
Do While rngSelection.InRange(rngBookmark) = True
Selection.Find.Style = ActiveDocument.Styles(strStyle)
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.HomeKey
' FAILING HERE: Returns TRUE when selection point
' is outside SpecBodyPairRange
var = rngSelection.InRange(rngBookmark)
Debug.Print var
Selection.HomeKey Unit:=wdLine, Extend:=wdMove
Selection.InsertBefore Chr(182)
Selection.EndKey
Selection.InsertAfter vbTab
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
If rngSelection.InRange(rngBookmark) <> True Then Exit Do
Loop
End Function
I was using CmpBookmarks in this current project, but it did not reliably returning the value of the current location. When the selection point is within the named range, it returns 8 for two loops, and then returns 6. When the selection point is outside the named range, CmpBookmarks returns 6.
Obviously, CmpBookmarks is deprecated. I can't find the return values that CmpBookmarks produces, and I can't find a modern equivalent function.
I confess I don't understand the difference between the named "SpecBodyPairRange" range and the range assigned to r, here:
Dim r As Range
I can see that "r" in this instance appears to hold the entire document. I studied Range Interface and Selection Interface on Microsoft.Office.Interop.Word, which I don't yet fully understand. I'm not a programmer, only a semi-technical writer self-taught in some coding who has the task of automating document conversion.
There must be a better way to compare the selection point to validate if it's within a named range, but I can't find it. Any pointers you can give me are sincerely appreciated!
Not a big Word VBA person but can you just compare the Start and End properties?
Dim bm As Bookmark
Set bm = ActiveDocument.Bookmarks("tester")
Debug.Print "Bookmark", bm.Start, bm.End
Debug.Print "Selection", Selection.Start, Selection.End
In order to determine whether one Range is within another use the InRange method:
Dim rngBookmark as Word.Range
Dim rngSelection as Word.Range
Set rngBookmark = ActiveDocument.Bookmarks("typeDef").Range
Set rngSelection = Selection.Range
If rngSelection.InRange(rngBookmark) = True Then
'Do something
End If
You could use VBA's InRange Method. For example:
Function FormatSpecHeadReturn(strStyle)
Dim Rng As Range
With ActiveDocument
Set Rng = .Bookmarks("SpecBodyPairRange").Range
With .Bookmarks("SpecBodyPairRange").Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^p"
.Replacement.Text = ""
.Style = strStyle
.Format = True
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = False
.Execute
End With
Do While .Find.Found
If .InRange(Rng) = False Then Exit Do
.Style = "SpecHead"
.Paragraphs.First.InsertBefore Chr(182)
.InsertAfter vbTab
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
End Function
I'm new to VBA. I have several long documents where a citation or a document number appears at the end of a paragraph. Luckily, these citations and document are enclosed in parentheses, which should make it easy to isolate. I need to move the content of those parentheses (including the parentheses themselves) to the front of each paragraph and then add two spaces after the closing parenthesis.
For example:
This is my text in Paragraph 1. (http://nytimes.com)
This is my text in Paragraph 2. (1.b.3B)
Should look like:
(http://nytimes.com) This is my text in Paragraph 1.
(1.b.3B) This is my text in Paragraph 2.
I found the answer in the following link useful, but can't seem to apply it to my case: Get paragraph no where txt is found, and move text to end of paragraph using Word 2010 vba
Many thanks in advance.
Here's what I have up to now, but the script just doesn't seem to run:
Sub Test1()
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
Selection.HomeKey Unit:=wdStory ' Start from the beginning of the doc.
For Each currPara In docRng.Paragraphs ' Loop through the paragraphs in the active document.
Set currRng = currDoc.Range(currPara.Range.Start, currPara.Range.End) ' Selects the current paragraph, so that the search is conducted paragraph by paragraph.
With Selection.Find
.ClearFormatting
.Text = "\(*\)"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
If currRng.Find.Execute Then
With Selection
.Select
.Cut
.StartOf Unit:=wdParagraph
.Paste
.InsertAfter " "
End With
End If
Next currPara
End Sub
You were very close to correct solution to move simple text. But, what I realised, it was a problem to move hyperlinks as syntax "\(*\)" didn't recognise hyperlinks. Therefore I put some additional small modifications. That works for me in Word 2010:
Sub Test1_Tested_incl_Hyper()
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
Selection.HomeKey Unit:=wdStory ' Start from the beginning of the doc.
For Each currPara In docRng.Paragraphs ' Loop through the paragraphs in the active document.
Set currRng = currDoc.Range(currPara.Range.Start, currPara.Range.End) ' Selects the current paragraph, so that the search is conducted paragraph by paragraph.
currRng.Select
With Selection.Find
.ClearFormatting
.Text = "\("
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute
End With
If Selection.Find.Found Then
With currDoc.Range(Selection.Range.Start, currPara.Range.End - 1)
.Select
.Cut
.StartOf Unit:=wdParagraph
.Paste
.InsertAfter " "
End With
End If
Next currPara
End Sub
EDIT- code for footers
Sub Test1_for_Footers()
Dim currDoc As Document
Set currDoc = ActiveDocument
Dim docRng As Range, currRng As Range, strRng As Range
Set docRng = ActiveDocument.StoryRanges(wdPrimaryFooterStory)
Dim currPara As Paragraph
Dim strText As String
For Each currPara In docRng.Paragraphs
currPara.Range.Select
With Selection.Find
.ClearFormatting
.Text = "\("
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute
End With
If Selection.Find.Found Then
Selection.Extend ")"
With Selection
.Select
.Cut
.StartOf Unit:=wdParagraph
.Paste
.InsertAfter " "
End With
End If
Next currPara
End Sub
With the Find function(Ctrl+F) I can search and select all words in Italicized font from a document.
How would this be done with vba?
I tried the macro recorder but the code I get there does not work.
Sub Makro1()
'
' Makro1 Makro
' Makro aufgezeichnet am 16.06.2011 von u0327336
'
Selection.Find.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End Sub
The goal would be to have all italic font words being selected/highlighted in the document.
thanks,
kay
The last effort actually works a treat in Word 2010. I'm not sure why the report was that it didn't work.
Here it is changed to ASCIIfy italics, which is what I want for text-based newsgroups:
Sub ASCIIfy()
Dim myString As Word.Range
Set myString = ActiveDocument.Content
With myString.Find
'// ensure unwanted formats aren't included as criteria
.ClearFormatting
'// we don't care what the text is
.Text = ""
'// find the italic text
.Font.Italic = True
'// loop for each match and surround with "_"
While .Execute
myString.Text = "_" & myString & "_"
myString.Font.Italic = False
myString.Collapse wdCollapseEnd
Wend
End With
End Sub
You may need to add :
Selection.Find.Font.Italic = True
That could became :
With Selection.Find
.Text = ""
.FOnt.Italic = True
'other search stuff
End with
EDIT: another try (not complete though)
Sub hilightItalic()
With ActiveDocument.Content.Find
' to ensure that unwanted formats aren't included as criteria
.ClearFormatting
'You don't care what the text is
.Text = ""
'Find the italic text
.Font.Italic = True
'Delete the text found
.Replacement.Text = ""
'delete all italic text
.Execute Replace:=wdReplaceAll
'.HitHighlight "", vbYellow, vbRed
End With
End Sub
But yet, the replace does work well but highlight does not work if there is no text. Anyone has an idea ?
EDIT 2: Found a working solution, even if i did not manage to have hithighlight working though
Sub hilightItalic()
Dim oRng As Word.Range
Set oRng = ActiveDocument.Content
With oRng.Find
' to ensure that unwanted formats aren't included as criteria
.ClearFormatting
'You don't care what the text is
.Text = ""
'Find the italic text
.Font.Italic = True
'Loop for each match and set a color
While .Execute
oRng.HighlightColorIndex = wdDarkYellow
oRng.Collapse wdCollapseEnd
Wend
End With
End Sub
Regards,
Max
Set Selection.Find.Font.Italic = True.
Selection.Find.ClearFormatting
' The next line does the trick.
Selection.Find.Font.Italic = True
With Selection.Find
.Text = "YourText"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Hint for the next time: Record a macro, perform the actions you want to automate, and look what code is recorded. That's how I found this. :D
[edit]
I see that you tried recording it. Weird that that didn't work.. :-S
You need to iterate through the cells in the range that you want to check, and specifically check if it has its font italicized. AFAIK .Italic is not a "findable" option.
The following code is an example of iterating through the cells to find what you need.
Sub TestMe2()
Dim rng As Range
'// change as needed to the proper worksheet reference
With ThisWorkbook.Worksheets(1)
'// replace the .Range statement with an appropriate range for your data
For Each rng In .Range(.Cells(1, 1), .Cells(100, 100))
If rng.Font.Italic = True Then
'// uses the yellow highlight color, change to suit your needs
rng.Interior.Color = 65535
End If
Next rng
End With
End Sub