The Excel code to do this would be something like:
Code:
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
Note: you'll need to set a vba reference to Word, via Tools|References.