Option Explicit
Dim FSO As Object, oFolder As Object, StrFldrs As String, strDocNm As String, FndArray() As String, StrOut As String
 
Sub ExtractStats()
Application.ScreenUpdating = False: Application.DisplayAlerts = wdAlertsNone: Application.WordBasic.DisableAutoMacros True
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
Dim xlApp As Object, xlWkBk As Object, StrTmp As String, r As Long, c As Long, StrXlNm As String
TopLevelFolder = GetFolder: StrFldrs = vbCr & TopLevelFolder: If TopLevelFolder = "" Then Exit Sub
strDocNm = ThisDocument.FullName: FndArray = Split(ThisDocument.Range.Text, vbCr)
StrOut = vbCr & vbTab & "Folder" & vbTab & "Filename" & vbTab & Join(FndArray, vbTab)
If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFldrs, vbCr))
  Call ProcessDocuments(CStr(Split(StrFldrs, vbCr)(i)))
Next
Application.WordBasic.DisableAutoMacros False: Application.DisplayAlerts = wdAlertsAll: Application.ScreenUpdating = True
StrXlNm = "\Documents\KeyWordStats (" & Format(Now, "YYYYMMDDhhmm") & ").xlsx"
Application.StatusBar = "Generating Output Workbook: " & StrXlNm
'Output the results to a new Excel workbook
Set xlApp = CreateObject("Excel.Application")
With xlApp
  .Visible = False
  Set xlWkBk = .Workbooks.Add
  ' Update the workbook.
  With xlWkBk.Worksheets(1)
    For r = 1 To UBound(Split(StrOut, vbCr))
      StrTmp = Split(StrOut, vbCr)(r)
        For c = 1 To UBound(Split(StrTmp, vbTab))
          .Cells(r, c).Value = Split(StrTmp, vbTab)(c)
        Next
    Next
    .Columns.AutoFit: .Rows.AutoFit
  End With
  xlWkBk.SaveAs FileName:="C:\Users\" & Environ("Username") & StrXlNm
  xlWkBk.Close: .Quit: Set xlWkBk = Nothing: Set xlApp = Nothing
End With
MsgBox "Finished. Results in: " & StrXlNm
End Sub
 
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders: StrFldrs = StrFldrs & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub

Sub ProcessDocuments(StrFldrNm As String)
Dim StrFlNm As String, wdDoc As Document, x As Long, y As Long
StrFlNm = Dir(StrFldrNm & "\*.doc", vbNormal)
While StrFlNm <> ""
  If StrFldrNm & "\" & StrFlNm <> strDocNm Then
    StrOut = StrOut & vbCr & vbTab & StrFldrNm & vbTab & StrFlNm
    Set wdDoc = Documents.Open(FileName:=StrFldrNm & "\" & StrFlNm, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      On Error Resume Next
      If .ProtectionType = wdAllowOnlyFormFields Then .Unprotect
      On Error GoTo 0
      If .ProtectionType = wdAllowOnlyFormFields Then StrOut = StrOut & vbTab & "Unable to Process - Protected": GoTo Prot
      'Get the stats for each keyword
      For x = 0 To UBound(FndArray) - 1
        With .Range
          With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = FndArray(x)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
          End With
          On Error Resume Next
          Do While .Find.Execute
            y = y + 1
            .Collapse wdCollapseEnd
          Loop
        End With
        StrOut = StrOut & vbTab & y: y = 0
      Next
Prot:
      .Close SaveChanges:=False
    End With
  End If
  DoEvents: StrFlNm = Dir()
Wend
Set wdDoc = Nothing
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function