Perhaps something like this (untested):

Dim wordApp As Application
Dim vWords As Variant
Dim vResults As Variant
Dim rCell As Range
Dim i As Long
Dim Counter As Long
Dim sPath As String

sPath = Range("B1").Text & Application.PathSeparator
Set wordApp = CreateObject("Word.Application")
vWords = Cells(3, 4).Resize(1, UBound(aKeyWords)).Value
ReDim vResults(1 To 1, 1 To UBound(vWords, 2))
With wordApp
For Each rCell In Range("B4:B" & _
Range("B" & Rows.Count).End(xlUp).Row)
.Documents.Open sPath & rCell.Text
.Visible = False
For i = 1 To UBound(vWords, 2)
With .Selection.Find
.MatchWholeWord = True
Counter = 0
Do While .Execute( _
FindText:=vWords(1, i), _
Forward:=True)
Counter = Counter + 1
Loop
End With
vResults(1, i) = Counter
Next i
rCell.Offset(0, 2).Resize(1, UBound(vResults, 2)).Value = _
vResults
Next rCell
.Quit
End With

Couple of things to point out:

1) no need to close and open the word app each time
2) no need to reference the target cells each time - storing their
values in a variable once is faster
3) storing the results in an array and writing it once is faster than
referencing/writing to each cell.
4) Depending on aKeyWords, vWords may be redundant - can't tell without
seeing the code.



In article .com,
"RosH" wrote:

Hello everyone,
I recently made a macro which would search for specific keywords in a
list of Microsoft word files and find the number of occurance of the
particular keyword. The problem is that everytime this macro opens a
new word file, it takes a lot of time. I am new to object oriented
programming. If anybody has any ideas of making this macro faster,
please suggest. Thank you.

A core part of the macro is as given below.

-----------------------------------------------------

For Each nDocFile In Range("B4:B" & FindLastRow("B4")).Cells
sDoc = Range("B1").Value & "\" & nDocFile.Value
Set wordApp = CreateObject("Word.Application")
nDocFile.Select
wordApp.Documents.Open (sDoc)
wordApp.Visible = False

For Each nWord In Range(Cells(3, 4), Cells(3, UBound(aKeywords) +
3)).Cells
sText = nWord

With wordApp.Selection.Find
.MatchWholeWord = True
Counter = 0
Do While .Execute(FindText:=sText, Forward:=True) =
True
Counter = Counter + 1
Loop
End With

nDocFile.Offset(0, nWord.Column - 2).Value = Counter

Next

wordApp.Quit
Set wordApp = Nothing

Next