VBA: Automate task in MS Word when running through Excel - vba

Question

I am trying to run this VBA in an excel file. The first part of this code allows me to select a file and open it. I now want to have the code search the file and format the words I ask it to. I have written this code in Word before and am now just having trouble getting it into excel. Is there a line such as "withwdapp" that tells the excel vba to perform the next set of steps in Word?
Sub Find_Key_Words()
'Open an existing Word Document from Excel
Dim FileToOpen
Dim appwd As Object
ChDrive "C:\"
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to import", _
FileFilter:="Word Files *.docx (*.docx),")
If FileToOpen = False Then
MsgBox "No file specified.", vbExclamation, "Error"
Exit Sub
Else
Set appwd = CreateObject("Word.Application")
appwd.Visible = True
appwd.Documents.Open Filename:=FileToOpen
End If
Dim objWord As Object, objDoc As Object, Rng As Object
Dim MyAr() As String, strToFind As String
Dim i As Long
'This holds search words
strToFind = "w1,w2, w3, w4"
'Create an array of text to be found
MyAr = Split(strToFind, ",")
Set objWord = CreateObject("Word.Application")
'Open the relevant word document : CAN THIS BE DELETED?
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

Answer 1

Change your code to this.
Const wdFindContinue = 1
Sub FnFindAndFormat()
Dim FileToOpen
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, ",")
FileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to import", _
FileFilter:="Word Files *.docx (*.docx),")
If FileToOpen = False Then Exit Sub
Set objWord = CreateObject("Word.Application")
'~~> Open the relevant word document
Set objDoc = objWord.Documents.Open(FileToOpen)
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