OzGrid

Sub Main()
  Dim p$, fn$, i As Long, j As Long, z As Long, r As Long, c As Integer
  Dim a, b, d, e, rr As Range, cc As Range
  Dim ws As Worksheet, o As Object, oW As Object, s$
  Dim fso As Object 'New Scripting.FileSystemObject
  
'******************* INPUTS **********************************
  'p = ThisWorkbook.Path & "\" 'Parent folder
  Set ws = Worksheets(1)
  ws.[B1] = ThisWorkbook.Path
  'Parent folder value
  p = ws.[B1]
  If Right(p, 1) <> "\" Then p = p & "\"
  'List of words to find in DOC files
  Set rr = ws.Range("A3", ws.Cells(Rows.Count, "A").End(xlUp))
'******************* END INPUTS ******************************
  
  'On Error GoTo EndSub
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Set oW = CreateObject("Word.Application")
  oW.DisplayAlerts = 0 'wdAlertsNone
  
  a = aFFs(p & "*.doc", , True)
  If Not IsArray(a) Then Exit Sub
  d = a 'd will contain only base filename.
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  'Array b to hold "x" value if file contains contents of column A.
  ReDim b(1 To rr.Cells.Count, 1 To UBound(a) + 1)
  
  z = -1
  For Each e In a
    Set o = GetObject(e)
    With o.Content.Find
      j = j + 1 'File counter, column
      z = 0 'cell content counter, row
      d(z) = fso.GetFile(CStr(e)).Name
      For Each cc In rr
        z = z + 1
        .clearformatting
        .Text = cc
        .MatchCase = False
        .matchwholeword = False
        .Execute
        If .found Then
          b(z, j) = "x"
          Else
          b(z, j) = ""
        End If
      Next cc
      o.Close False
    End With
  Next e
  
  'Clear row 2, doc filenames.
  ws.Rows(2).ClearContents
  'Add base file names starting at B1 and to right.
  ws.[B2].Resize(, UBound(a) + 1) = d
  'Add array b, x's if found content in DOC files from column A.
  ws.[B3].Resize(rr.Cells.Count, UBound(a) + 1) = b
  'Fomat columns with filenames
  With ws.[B2].Resize(, UBound(a) + 1)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 90
    .EntireColumn.ColumnWidth = 3.35
  End With
  
EndSub:
  Set fso = Nothing
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub

'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
  Optional tfSubFolders As Boolean = False) As Variant
  
  Dim s As String, a() As String, v As Variant
  Dim b() As Variant, i As Long
  
  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s " & extraSwitches).StdOut.readall
    Else
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b " & extraSwitches).StdOut.readall
  End If
  
  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    Debug.Print myDir & " not found.", vbCritical, "Macro Ending"
    Exit Function
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
  
  For i = 0 To UBound(a)
    If Not tfSubFolders Then
      s = Left$(myDir, InStrRev(myDir, "\"))
      'add the folder name
      a(i) = s & a(i)
    End If
  Next i
  aFFs = sA1dtovA1d(a)
End Function

Function sA1dtovA1d(strArray() As String) As Variant
  Dim varArray() As Variant, i As Long
  ReDim varArray(LBound(strArray) To UBound(strArray))
  For i = LBound(strArray) To UBound(strArray)
    varArray(i) = CVar(strArray(i))
  Next i
  sA1dtovA1d = varArray()
End Function