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