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

[mancubus]

:thumb

[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

[lkelsen]

you are welcome.


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

Mancubus, nah there arent any non-english characters as far as i am aware?

apo, your code almost achieves what i'm after except that it places " " marks at either end of the string when in the spreadsheet?? Also it keeps the file extension in the string but, I can use this to my advantage in another function i'm writing.

Luke

[apo]

Try changing it to:



Z = Split(Replace(Replace(CreateObject("wscript.shell").exec("cmd /c forfiles /P " & fPath & " /S /M *.xl?? /c ""cmd /c echo @file """).stdout.readall, Chr(32) & Chr(34), ""), Chr(34), ""), vbCrLf)

[lkelsen]

Works perfect thank you apo!

[apo]

Also..

To just get the filename (no extension)..

Replace @FILE with @FNAME in that line of code..

See here:

https://technet.microsoft.com/en-au/library/cc753551.aspx

[snb]

Although an interesting option, on my XP system I wasn't able to get any result.

[apo]

I read somewhere that (for XP) you can download the Forfiles.exe and copy it to: C:\ windows\system32

I don't have XP.. I wonder if that will make it work..

[lkelsen]

Also..

To just get the filename (no extension)..

Replace @FILE with @FNAME in that line of code..

See here:

https://technet.microsoft.com/en-au/library/cc753551.aspx

Awesome, works great!

All of you here have been such a great help which i appreciate, as for me everything is trial and error with my entry level understanding of VBA, and even having the mind of approach to programming in general.

No obligation snb, mancubus and apo, but are you able to explain how each part of your code works? Always nice to know why it does this, that and so on..

Cheers,

Luke