Sub ListFiles()
Dim fso As Object
Dim strName As String, strDir As String
Dim strArr(1 To 65536, 1 To 1) As String, i As Long
strDir = GetFolder()
Let strName = Dir$(strDir & "\*" & ".pdf")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = strDir & "\" & strName
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(strDir), strArr(), i)
Set fso = Nothing
Workbooks.Add
If i > 0 Then
Range("A1").Resize(i).Value = strArr
End If
End Sub
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef i As Long)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.Path & "\*" & ".pdf")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = SubFolder.Path & "\" & strName
Let strName = Dir$()
Loop
Call recurseSubFolders(SubFolder, strArr(), i)
Next
End Sub
Function GetFolder()
Dim sDir As String
Dim objFolder As Object
On Error GoTo errorhandler
'// Selects the Root PC Dir!
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please Select Folder", 0, 0)
If Not objFolder Is Nothing Then
'// Is it the Root Dir?...if so change
If Len(objFolder.Items.Item.Path) > 3 Then
sDir = objFolder.Items.Item.Path & Application.PathSeparator
Else
sDir = objFolder.Items.Item.Path
End If
End If
Set objFolder = Nothing 'release object from memory
If Len(sDir) = 0 Then Exit Function
GetFolder = sDir
errorhandler:
End Function