Button to Search Subfolders for files

[lkelsen]

Hi team,

I have the following code which successfully populates a worksheet with any excel files where the file name starts with the project number "9876".

This is the code:

Private Sub btnPopulate_Click()Dim sPath As String, fileName As String, i As Integer


    Application.ScreenUpdating = False


    sPath = "I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\"


    fileName = Dir(sPath & "9876*.xl??")


Do While fileName <> ""
i = i + 1
Cells(i, 1) = fileName
fileName = Dir()
Loop


    Application.ScreenUpdating = True


End Sub

How can I make it search all the sub-folders within the specified sub-directory's of sPath?

Cheers,

Luke Kelsen

[Sixthsense..]

Try this untested code

Option Explicit
Private Sub btnPopulate_Click()
Dim sPath As String, fileName As String, i As Integer, x As Byte, sExt As String
Dim fso, oFolder, oSubfolder, oFile, queue As Collection

sPath = "I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\"

Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder(sPath)

Application.ScreenUpdating = False

Do While queue.Count > 0
    Set oFolder = queue(1)
    queue.Remove 1
    
    For Each oSubfolder In oFolder.SubFolders
        queue.Add oSubfolder
    Next oSubfolder
    
    For Each oFile In oFolder.Files
        sExt = Right$(oFile.Name, Len(oFile.Name) - InStrRev(oFile.Name, "."))
        x = InStr(sExt, "xl")
        If x Then
            If Left(oFile.Name, 4) = "9876" Then
                i = i + 1
                Cells(i, 1) = fileName
            End If
        End If
    Next oFile
Loop
     
Application.ScreenUpdating = True
    
End Sub

[snb]

2 lines suffice:

Sub M_snb()
   sn=split(createobject("wscript.shell").exec("cmd /c Dir ""I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\9876*.xl??"" /b/s").stdout.readall,vbcrlf)
   sheet1.cells(1).resize(ubound(sn))=application.transpose(sn)
end sub

NB. You'd better avoid using spaces in foldernames.

[fredlo2010]

Here is my code.

Untested

Option Explicit


Private Sub btnPopulate_Click()
    
    Dim fso As Object
    Dim oFolder As Object
    Dim sPath As String
    Dim sFiles(1 To 1048576) As String
    Dim i As Long
     
    Application.ScreenUpdating = False
    
    sPath = "I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fso.GetFolder(sPath)
    
    ' Call the recursive function
    Call GetFiles(oFolder, "9876*.xl??", sFiles, i, True)
    
    ' Copy the data to the range at the end.
    Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(i).Value = sFiles
    
    Application.ScreenUpdating = True
     
End Sub


Private Sub GetFiles(ByVal oFolder As Object, _
                     ByVal strCriteria As String, _
                     ByRef arrFiles() As String, _
                     ByRef i As Long, _
                     Optional ByVal bIncludeSubFolders As Boolean = True)


    Dim oFile As Object
    Dim oSubFolder As Object


    ' Get all the files
    For Each oFile In oFolder.Files
        If oFile.Name Like strCriteria Then
            arrFiles(i) = oFile.Name
            i = i + 1
        End If
    Next


    ' If you want to grab the infromation from all subfoders then
    ' gro through the subfolders and call the function recursivly
    If bIncludeSubFolders Then
        For Each oSubFolder In oFolder.SubFolders
            Call GetFiles(oSubFolder, strCriteria, arrFiles, i, bIncludeSubFolders)
        Next
    End If


End Sub

[lkelsen]

Thank you all three of you for your replies.

snb your 2 lines of code work like a charm! Just out of curiosity, why do you advise to avoid using spaces in foldernames?

Cheers again for your help,

Luke

[snb]

If foldernames do not contain spaces the code can do without the often as complicated considered quotation marks.

Instead of
sn=split(createobject("wscript.shell").exec("cmd /c Dir ""I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\9876*.xl??"" /b/s").stdout.readall,vbcrlf)

you can use

sn=split(createobject("wscript.shell").exec("cmd /c Dir I:\02_Clients\Test_Client\Projects\9876_-_Core_Group_Test_Project\9876*.xl?? /b/s").stdout.readall,vbcrlf)

[lkelsen]

I see, unfortunately our hundreds of already existing projects already contain spaces and this is the preference for the way the company I work for, names their folders.

This maybe something relative, I want to place a declared string in the first line which would replace the directory. So I would have the following:

Sub M_snb() Dim sn As Variant
Dim sPath As String 'This is the declared string name

sPath = ActiveWorkbook.Path & "\"
    
    sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir sPath ""9876*.xl??"" /b/s").StdOut.ReadAll, vbCrLf) 'sPath replaces the directory in question
    Sheet1.Cells(1).Resize(UBound(sn)) = Application.Transpose(sn) 'I get the run-time error type 13 on this line of code

End Sub

I get a run-time error 13 type mismatch when i execute. The reason I need the sPath string here is because this workbook will exist in every project folder we create so the directory path is always going to change.

Cheers,

Luke

[snb]

That's exactly illustrating the problem with spaces containing foldernames

Sub M_snb() 
    c00="I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\"

    sn=split(createobject("wscript.shell").exec("cmd /c Dir """ & c00 & "9876*.xl??"" /b/s").stdout.readall,vbcrlf) 
    sheet1.cells(1).resize(ubound(sn))=application.transpose(sn) 
End Sub

[lkelsen]

Yup I thought so, but your code has once again solved my problem and I thank you for this snb!

Much appreciated once again

Luke

[lkelsen]

snb, Sorry to drag out this solved thread but how would I use this code so that it only populates my spreadsheet with only the excel filename not the directory string before it and also ignore the .xls file exstension?

I could use a formula in the actual spreadsheet itself but this will create a whole lot of unnecessary code..

[snb]

in that case you do not want to look in subfolders : /s can be omitted
the replacement of the fileextension can be done by replace( .. , .. ), or somewhat slickier (see below)

Sub M_snb() 
    c00="I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\" 
     
    sn=split(createobject("wscript.shell").exec("cmd /c Dir """ & c00 & "9876*.xl??"" /b").stdout.readall,".xls" & vbcrlf) 
    sheet1.cells(1).resize(ubound(sn))=application.transpose(sn) 
End Sub

[lkelsen]

Sorry for the late reply been on other jobs.

No I still want the spreadsheet to list every single excel within the specified folder and subfolders but I just dont want the full path to be listed.
For example If it pulls a sheet from I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\8 - Purchasing\9876-EST-001 - Rev 0 - Luke.xlsx

Then say in Cell A1 all I want it to say is "9876-EST-001 - Rev 0 - Luke" (The name of the excel file).

Whether that is possible or not? Never mind if not I can just use a formula in the spreadsheet itself.

Cheers,

Luke

[snb]

Sub M_snb() 
    c00="I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\" 
     
    sn=split(createobject("wscript.shell").exec("cmd /c Dir """ & c00 & "9876*.xl??"" /b").stdout.readall,".xls" & vbcrlf) 
    for j=0 to ubound(sn)
      sn(j)=dir(sn(j))
    next
    sheet1.cells(1).resize(ubound(sn))=application.transpose(sn) 
End Sub

[mancubus]

how about GetBaseName method of FileSystemObject?

Sub M_snb()
    
    c00 = "I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\"
    sn = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir """ & c00 & "9876*.xl??"" /b").StdOut.ReadAll, vbCrLf)

    Set fso = CreateObject("Scripting.FileSystemObject")
    
    For j = 0 To UBound(sn)
        sn(j) = fso.GetBaseName(sn(j))
    Next
    
    Sheet1.Cells(1).Resize(UBound(sn)) = Application.Transpose(sn)

End Sub

[snb]

Seems to me equally excellent

[mancubus]

[lkelsen]

Never thought i'd get back here, been changed departments in the company.

snb for some reason with your code i get a:

"Run-time error '52':

Bad file name or number"

mancubus's alternative seems to work though, however i had to reintroduce the omitted /s to get all sub folder files. This now works brilliantly!

Thanks very much to the both of you for your input and sorry for the late response.

Cheers,


Luke

[mancubus]

you are welcome.


for RTE 52:
do names of the files or folders contain, lets say, non-english characters?

[snb]

rather obvious:

Sub M_snb() 
    c00="I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project\" 
    sn=split(createobject("wscript.shell").exec("cmd /c Dir """ & c00 & "9876*.xl??"" /b").stdout.readall,".xls" & vbcrlf) 

    For j=0 To ubound(sn) -1
        sn(j)=dir(sn(j)) 
    Next 

    sheet1.cells(1).resize(ubound(sn))=application.transpose(sn) 
End Sub

[apo]

Late to the party.. but maybe this is an interesting alternative also..

Private Sub CommandButton1_Click()
    fPath = """" & "I:\02 Clients\Test Client\Projects\9876 - Core Group Test Project" & """"
    Z = Split(CreateObject("wscript.shell").exec("cmd /c forfiles /P " & fPath & " /S /M  *.xl?? /c ""cmd /c echo  @file """).stdout.readall, vbCrLf)
    Sheets("Sheet1").Cells(1).Resize(UBound(Z)) = Application.Transpose(Z)
End Sub