Option Explicit
Public FSO As Object 'a FileSystemObject
Public oFolder As Object 'the folder object
Public oSubFolder As Object 'the subfolders collection
Public oFiles As Object 'the files object
Public i As Long, j As Long
Public DocTgt As Document
 
Sub Main()
' Minimise screen flickering
Application.ScreenUpdating = False
Dim StrFolder As String
' Browse for the starting folder
StrFolder = GetTopFolder
If StrFolder = "" Then Exit Sub
' Initialize the counters
i = 0: j = 0
' Search the top-level folder
Set DocTgt = Documents.Add()
Call GetFolder(StrFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(StrFolder)
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox i & " of " & j & " files processed.", vbOKOnly
End Sub
 
Function GetTopFolder() As String
GetTopFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Sub SearchSubFolders(strStartPath As String)
If FSO Is Nothing Then
  Set FSO = CreateObject("scripting.filesystemobject")
End If
Set oFolder = FSO.GetFolder(strStartPath)
Set oSubFolder = oFolder.subfolders
For Each oFolder In oSubFolder
  Set oFiles = oFolder.Files
  ' Search the current folder
  Call GetFolder(oFolder.Path & "\")
  ' Call ourself to see if there are subfolders below
  SearchSubFolders oFolder.Path
Next
End Sub
 
Sub GetFolder(StrFolder As String)
Dim strFile As String
strFile = Dir(StrFolder & "*.doc")
' Process the files in the folder
While strFile <> ""
  ' Update the status bar is just to let us know where we are
  Application.StatusBar = StrFolder & strFile
  Call UpdateFile(StrFolder & strFile)
  strFile = Dir()
Wend
End Sub
 
Sub UpdateFile(strDoc As String)
Dim Doc As Document
' Open the document
Set Doc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)
With Doc
  If .ProtectionType = wdNoProtection Then
    Call GetTableData(Doc)
    ' Update the file counter for processed files
    i = i + 1
  Else
    ' Output a 'protected' file report in the document from which the macro is run.
    ThisDocument.Range.InsertAfter vbCr & strDoc & " protected. Not updated."
  End If
  ' Update the main file counter
  j = j + 1
  .Close SaveChanges:=False
End With
' Let Word do its housekeeping
DoEvents
Set Doc = Nothing
End Sub
 
Sub GetTableData(Doc As Document)
Dim Tbl As Table, i As Long, Rng As Range
With Doc
  For Each Tbl In .Tables
    For i = 1 To Tbl.Rows.Count
      Set Rng = Tbl.Cell(i, 2).Range
      Rng.End = Rng.End - 1
      If Rng.Text = "Yes" Then
        Set Rng = Tbl.Rows(i).Range
        DocTgt.Characters.Last.FormattedText = Rng.FormattedText
      End If
    Next
  Next
End With
End Sub