VBA highlight adjacent word

macrointraining · #1 09-01-2015, 04:08 PM

Hi,

I am analyzing paragraphs from multiple documents with a VBA macro to highlight word listings from an array. I would also like each word adjacent (i.e., one word to the left, and one word to the right) to the original word in the paragraphs highlighted as well. The macro below works fine to highlight the words from the array, but am unable to figure out how to highlight the adjacent words in the paragraphs.

For example, for:
- **The nearest county has one current listing, while the next closest county has two listings.**

- The macro highlights *one* and *two*.
- The desired result would highlight *has one current* and *has two listings*.

Any help is appreciated.

Thanks.

Office 2007
Windows 7

Sub Highlight_Plus_Adjacent_Words()

Dim MyWords As Variant
Dim RngWords As Range
Dim i As Integer
Dim lngHCI As Long

lngHCI = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdYellow

MyWords = Split("one,two,three,four,five", ",")

For i = 0 To UBound(MyWords)
Set RngWords = Selection.Range
With RngWords.Find
.ClearFormatting
' the below works for the MyWords as listed with no adjacent words highlighted
.text = "<" & MyWords(i) & ">"
' the following did not work for .text to include one adjacent word on each side
' .text = "<*>" & "<" & MyWords(i) & ">" & "<*>"
' .text = "/([A-Za-z0-9.,-]+\s*){0,1}\" & MyWords(i) & "(\s|[,.!?])(\s*[A-Za-z0-9.,-]+){0,2}/"
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.MatchCase = False
.MatchAllWordForms = False
.Format = True
.MatchWholeWord = True

.Replacement.ClearFormatting
.Replacement.Highlight = True
.Replacement.text = "^&"
.Execute Replace:=wdReplaceAll
End With
Next i

End Sub

gmayor · #2 09-02-2015, 01:48 AM

The following should do the trick for selected text

Code:

Sub Highlight_Plus_Adjacent_Words()

Dim MyWords As Variant
Dim RngWords As Range
Dim oRng As Range
Dim i As Integer

    MyWords = Split("one,two,three,four,five", ",")
    Set oRng = Selection.Range
    For i = 0 To UBound(MyWords)
        Set RngWords = oRng
        With RngWords.Find
            Do While .Execute(FindText:=MyWords(i), MatchWholeWord:=True)
                With RngWords
                    .Start = .Previous.Words(1).Start
                    .End = .Next.Words(1).Next.Words(1).End
                    .MoveEndWhile Chr(32), wdBackward
                    .HighlightColorIndex = wdYellow
                    .Collapse 0
                    If .Start >= oRng.End Then Exit Do
                End With
            Loop
        End With
    Next i
lbl_Exit:
    Set oRng = Nothing
    Set RngWords = Nothing
    Exit Sub
End Sub

macropod · #3 09-02-2015, 07:00 PM

macrotraining: At the top of the Office forum where you posted your thread is -
*** Do not post WORD questions here! ***

Please post Word questions in the appropriate Word forum, in this case the Word VBA forum (https://www.msofficeforums.com/word-vba/).

Also, when posting code, please use the code tags, inserted via the # button on the posting menu.

Now moving thread to the correct forum...

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
How to delete the two non-adjacent rows in a table Word	beginner	Word	2	01-05-2015 05:47 AM
How to conditionally format cells in Col. A if it matches adjacent cell in Col. B?	alshcover	Excel	2	06-03-2014 12:50 PM
Word Macro to find and delete rows that contain adjacent cells containing "."	AlexanderJohnWilley	Word VBA	7	11-08-2012 10:15 AM
Conditional Formatting Expiration Dates Based on Text in Adjacent Cell	Frogggg	Excel	1	10-25-2011 08:44 PM
find - reading highlight - highlight all / highlight doesn't stick when saved	bobk544	Word	3	04-15-2009 03:31 PM