Hello Simon,

This will let you choose the parent folder. The macro is set to search all subfolders. You can restrict the search level od subfolders if like.

Let me know if you have any issues with the code.

' Written:  January 31, 2017
' Author:   Leith Ross
' Summary:  Recursively finds a file in a folder. The level of subfolders to search can be specified.
'           The output is saved to a 1-D zero based Variant Array. Each element holds the full path to 
'           each found file. 


' Subfolder Level Values:
'                        -1 = All Subfolders
'                         0 = Parent Folder Only
'                         1 = Subfolders in the Parent Folder
'                         2 = SubFolders of Subfolders in Parent Folder
'                         etc.




Const Search_All    As Long = -1


Private oShell      As Object


Function FindFile(ByVal FolderPath As Variant, ByRef FilePaths As Variant, Optional ByVal SubfolderLevel As Long)


    Dim n           As Long
    Dim oFile       As Object
    Dim oFiles      As Object
    Dim oFolder     As Variant
    Dim oShell      As Object
        
        If oShell Is Nothing Then
            Set oShell = CreateObject("Shell.Application")
        End If
        
        Set oFolder = oShell.Namespace(FolderPath)
            If oFolder Is Nothing Then
                MsgBox "The Folder '" & FolderPath & "' Does Not Exist.", vbCritical
                SearchSubfolders = False
                Exit Function
            End If
            
            Set oFiles = oFolder.Items
            
            oFiles.Filter 64, "log.doc"
                For Each oFile In oFiles
                    n = UBound(FilePaths)
                    FilePaths(n) = oFile.Path
                    ReDim Preserve FilePaths(n + 1)
                Next oFile
            
            oFiles.Filter 32, "*"
                If SubfolderLevel <> 0 Then
                    For Each oFolder In oFiles
                        Call FindFile(oFolder, FilePaths, SubfolderLevel - 1)
                    Next oFolder
                End If
                
End Function


Sub GetFormData() 


    Dim Cell       As Range
    Dim FilePaths  As Variant
    Dim Folder     As Variant
    Dim FrmField   As Object
    Dim i          As Long
    Dim j          As Long
    Dim Path       As Variant
    Dim wdApp      As Object
    Dim wdDoc      As Object
    Dim WkSht      As Worksheet


        Set Folder = GetFolder 
        If Folder Is Nothing Then Exit Sub 


        Application.ScreenUpdating = False 


        Set WkSht = ActiveSheet 
        Set Cell = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Offset(1, 0)


        ReDim FilePaths(0)


        Call FindFile(Folder, FilePaths, Search_All)


        Set wdApp = CreateObject("Word.Application")


            For Each Path In FilePaths
                Set wdDoc = wdApp.Documents.Open(Filename:=Path, AddToRecentFiles:=False, Visible:=False) 
                    With wdDoc 
                        j = 0 
                        For Each FmFld In .FormFields 
                            j = j + 1 
                            Cell.Offset(0, j) = FmFld.Result 
                        Next FmFld
                    End With 
                Set Cell = Cell.Offset(1, 0)
                wdDoc.Close SaveChanges:=False 
            Next Path
 
        Application.ScreenUpdating = True 


End Sub 
 
Function GetFolder() As Object 


    Dim Folder As Variant
    
        With Application.FileDialog(msoFileDialogFolderPicker)
            .AllowMultiSelect = False
            .Show
            If .SelectedItems.Count = 1 Then
                Folder = .SelectedItems(1)
                Set GetFolder = CreateObject("Shell.Application").Namespace(Folder)
            End If
        End With


End Function