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 WkSht As Worksheet, i As Long, j As Long
Dim wdApp As New Word.Application
 
Sub Main()
' Minimise screen flickering
Application.ScreenUpdating = False
'Note: this code requires a reference to the Word object model
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
' Browse for the starting folder
strFolder = GetTopFolder
If strFolder = "" Then Exit Sub
Set wdApp = CreateObject("Word.Application")
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
j = i
' Search the top-level folder
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 "Data from " & i - j & " files extracted.", 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 <> ""
  i = i + 1
  ' Update the status bar is just to let us know where we are
  Application.StatusBar = strFolder & strFile
  Call UpdateFileData(strFolder & strFile)
  strFile = Dir()
Wend
End Sub
 
Sub UpdateFileData(strDoc As String)
Dim wdDoc As Document, wdDocProp As Object
' Open the document
WkSht.Cells(i, 1).Value = strDoc
Set wdDoc = wdApp.Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)
With wdDoc
  For Each wdDocProp In .CustomDocumentProperties
    With wdDocProp
      Select Case .Name
        Case "Health and Safety": WkSht.Cells(i, 5).Value = .Value
      End Select
    End With
  Next
  .Close SaveChanges:=False
End With
' Let Word do its housekeeping
DoEvents
Set wdDoc = Nothing
End Sub