VBA: Format MS Word text - vba

Question

I am trying to format text of multiple words. So far, the code below will only allow me to format the font of one word. What do I need to add / delete in order to have as many words as I input be formatted?
Cheers!
Sub FnFindAndFormat()
Dim objWord
Dim objDoc
Dim intParaCount
Dim objParagraph
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("C:\USERPATH")
objWord.Visible = True
intParaCount = objDoc.Paragraphs.Count
Set objParagraph = objDoc.Paragraphs(1).range
objParagraph.Find.Text = "deal"
Do
objParagraph.Find.Execute
If objParagraph.Find.Found Then
objParagraph.Font.Name = "Times New Roman"
objParagraph.Font.Size = 20
objParagraph.Font.Bold = True
objParagraph.Font.Color = RGB(200, 200, 0)
End If
Loop While objParagraph.Find.Found
End Sub

Answer 1

Let's say your word document looks like this
Since I am not sure whether you are doing this from Word-VBA or from some other application like say Excel-VBA so I am including both methods.
Now if you are doing this from Word-VBA then you do not need to LateBind with it. Use this simple code.
Option Explicit
Sub Sample()
Dim oDoc As Document
Dim MyAr() As String, strToFind As String
Dim i As Long
'~~> This holds your search words
strToFind = "deal,contract, sign, award"
'~~> Create an array of text to be found
MyAr = Split(strToFind, ",")
'~~> Open the relevant word document
Set oDoc = Documents.Open("C:\Sample.docx")
'~~> Loop through the array to get the seacrh text
For i = LBound(MyAr) To UBound(MyAr)
With Selection.Find
.ClearFormatting
.Text = MyAr(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Execute
'~~> Change the attributes
Do Until .Found = False
With Selection.Font
.Name = "Times New Roman"
.Size = 20
.Bold = True
.Color = RGB(200, 200, 0)
End With
Selection.Find.Execute
Loop
End With
Next i
End Sub
However if you are doing from say Excel-VBA then use this
Const wdFindContinue = 1
Sub FnFindAndFormat()
Dim objWord As Object, objDoc As Object, Rng As Object
Dim MyAr() As String, strToFind As String
Dim i As Long
'~~> This holds your search words
strToFind = "deal,contract, sign, award"
'~~> Create an array of text to be found
MyAr = Split(strToFind, ",")
Set objWord = CreateObject("Word.Application")
'~~> Open the relevant word document
Set objDoc = objWord.Documents.Open("C:\Sample.docx")
objWord.Visible = True
Set Rng = objWord.Selection
'~~> Loop through the array to get the seacrh text
For i = LBound(MyAr) To UBound(MyAr)
With Rng.Find
.ClearFormatting
.Text = MyAr(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Execute
Set Rng = objWord.Selection
'~~> Change the attributes
Do Until .Found = False
With Rng.Font
.Name = "Times New Roman"
.Size = 20
.Bold = True
.Color = RGB(200, 200, 0)
End With
Rng.Find.Execute
Loop
End With
Next i
End Sub
OUTPUT

Answer 2

Works like a charm for me:
Public Sub Find_some_text()
'setting objects
Dim objWord
Dim objDoc
Dim objSelection
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("H:\Test.docx")
'set visibility
objWord.Visible = True
'set array of words to format
words_list = Array("Findme_1", "Findme_2", "etc")
'formatting text
For Each w In words_list
Set Frange = objDoc.Range
Frange.Find.Text = w
Do
Frange.Find.Execute
If Frange.Find.Found Then
Frange.Font.Name = "Times New Roman"
Frange.Font.Size = 20
Frange.Font.Bold = True
Frange.Font.Color = RGB(200, 200, 0)
End If
Loop While Frange.Find.Found
Next
'de-set visibility
objWord.Visible = False
'saving (optional)
objDoc.Save
End Sub

Answer 3

This code:
For Each w In words_list
Set Frange = objDoc.Range
Frange.Find.Text = w
Do
Frange.Find.Execute
If Frange.Find.Found Then
Frange.Font.Name = "Times New Roman"
Frange.Font.Size = 20
Frange.Font.Bold = True
Frange.Font.Color = RGB(200, 200, 0)
End If
Loop While Frange.Find.Found
Next
is inefficient. Try:
With objDoc.Range.Find
.ClearFormatting
With .Replacement
.ClearFormatting
.Text = "^&"
With .Font
.Name = "Times New Roman"
.Size = 20
.Bold = True
.Color = RGB(200, 200, 0)
End With
End With
.Format = True
.Forward = True
.Wrap = 1 'wdFindContinue
For Each w In words_list
.Text = w
.Execute Replace:=2 'wdReplaceAll
Next
End With