capture folder name and file name if folder holds pdf

jcg

Board Regular
Joined
Jul 12, 2002
Messages
156
I want to search a particular file folder that has 5 subfolders (each state) that then has multiple county folders. I want to be able to scan the folders and determine if there is a pdf inside and then return the name of that file and folder to a cell in excel. can someone point me in the right direction? Thanks.
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

btadams

Well-known Member
Joined
Jan 6, 2003
Messages
1,942
Try this:

Code:
Sub TestListFiles()
Dim strFolder As String
Dim FileS As FileSearch
Dim F As Variant
Dim x As Integer

    strFolder = GetFolder()
    Set FileS = Application.FileSearch
    With FileS
       .NewSearch
       .Filename = "*.pdf"
       .LookIn = strFolder
       .SearchSubFolders = True
       .Execute
    End With
    Application.ScreenUpdating = False
    Workbooks.Add ' create a new workbook for the folder list

    x = 2
    For Each F In Application.FileSearch.FoundFiles
       Cells(x, 1) = F
       x = x + 1
    Next F

     Application.ScreenUpdating = True
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
 

jcg

Board Regular
Joined
Jul 12, 2002
Messages
156
Thank you so much for your effort on this!!!

When I run the script I get an "Run-time Error 445 Object does not support this action" at the Set FileS = Application.FileSearch line of code.

Thanks again for your help
 

btadams

Well-known Member
Joined
Jan 6, 2003
Messages
1,942
I'm not sure what that error might be. What version of Excel are you running and what OS do you have?
 

jcg

Board Regular
Joined
Jul 12, 2002
Messages
156
I am using office 2007 on windows XP
 

btadams

Well-known Member
Joined
Jan 6, 2003
Messages
1,942
I just did a google search on Excel FileSearch and found that, SURPRISE!, Excel 2007 no longer supports the FileSearch property :confused: . There must be a workaround. I'll do some more searching. I'm sure someone on this board has stumbled across this by now.
 

btadams

Well-known Member
Joined
Jan 6, 2003
Messages
1,942
Here's a workaround that I adapted from a post by Nate Oliver. After pasting the code into a standard module you may need to set a reference to the Microsoft Scripting Runtime library (go to the Tools menu and choose References) :

Code:
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
 

NateO

Legend
Joined
Feb 17, 2002
Messages
9,700
Here's a workaround that I adapted from a post by Nate Oliver. After pasting the code into a standard module you may need to set a reference to the Microsoft Scripting Runtime library (go to the Tools menu and choose References) :
Quick FYI, you won't need a reference, it's using Late Binding. :)
 

LxQ

Well-known Member
Joined
Feb 9, 2006
Messages
619
When I run this report it stops where it reaches a folder where access is denied. Is it too complicated to code it to skip those folders and continue the list and not just quit?
 

Forum statistics

Threads
1,181,420
Messages
5,929,801
Members
436,696
Latest member
Mr Rice

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top