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
Dim LRow As Long
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim XlWkSht As Excel.Worksheet
 
Sub Main()
' Minimise screen flickering
Application.ScreenUpdating = False
MsgBox ActiveSheet.Name
Set XlWkSht = ActiveSheet
MsgBox ActiveSheet.Name
LRow = XlWkSht.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
Set wdApp = New Word.Application
wdApp.Visible = True
Dim StrFolder As String
' Browse for the starting folder
StrFolder = GetTopFolder
If StrFolder = "" Then Exit Sub
' Search the top-level folder
Call GetFolder(StrFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(StrFolder)
' Return control of status bar to Excel
Application.StatusBar = ""
'Close Word
wdApp.Quit
' Restore screen updating
Application.ScreenUpdating = True
Set wdDoc = Nothing: Set wdApp = Nothing: Set XlWkSht = Nothing
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 UpdateWkBk(StrFolder, strFile)
  strFile = Dir()
Wend
End Sub
 
Sub UpdateWkBk(StrFolder As String, strFile As String)
Dim StrRef As String
' Open the document
Set wdDoc = wdApp.Documents.Open(StrFolder & strFile, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)
With wdDoc
  If .ProtectionType = wdNoProtection Then
    ' Find and Extract the data
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "^13[!^13]@" & strFile & "[!^13]{1,}"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True
        .Execute
      End With
      Do While .Find.Found
        .Start = .Start + 1
        If .Words.First.Font.Bold = True And .Words.First.Font.Italic = True Then
          .Copy
          With XlWkSht
            .Cells(LRow, 1).Value = strFile
            .Cells(LRow, 2).Paste
          End With
          LRow = LRow + 1
        End If
        .Collapse wdCollapseEnd
        .Find.Execute
      Loop
    End With
  End If
  'Close the document
  .Close SaveChanges:=False
End With
' Let Word do its housekeeping
DoEvents
End Sub