Alternative of .SearchSubFolders = False for 2010

[pawasthi]

Hi Friends,

I am using below code to list down all the .xls files in a folder. Its working fine but now I have new requirement to list down all the files in the subfolders also. So I have done some google and found ".SearchSubFolders = False". But this does not work with Excel 2010. So whats the alternative or how I can modify my code to get the file list from sub folders too.

Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select the Application Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
Set fldr = Nothing

FolderName = sItem
wbCount = 0
wbName = Dir(FolderName & "\" & "*.xls")
While wbName <> ""
wbCount = wbCount + 1
ReDim Preserve wbList(1 To wbCount)
wbList(wbCount) = wbName
wbName = Dir
Wend
If wbCount = 0 Then Exit Sub
Set wbThis = ThisWorkbook

I need to get the above code working with the "Searching of files in subfolders (recursively)"


Thanks in advance

[Kenneth Hobs]

Try the class method that I posted. http://www.vbaexpress.com/forum/showthread.php?t=37784

[thmh]

here is function and macro i use to copy workbooks from folders ,




Sub copy_folder()

Dim basebook As Workbook
Dim mybook As Workbook
Dim n As Long
Dim ws As Worksheet

Dim i As Long

Dim colFiles As New Collection

Dim fName As String, s() As String, NfName As String


RecursiveDir colFiles, "E:\Users\", "*.xlsm", True



With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.CutCopyMode = False
.ScreenUpdating = False
.DisplayAlerts = False


' MsgBox "There were " & colFiles.count & " file(s) found."


For i = colFiles.count To 1 Step -1


fName = colFiles(i)
s() = Split(fName, "\")
ReDim Preserve s(0 To (UBound(s) - 1))
NfName = s(UBound(s))
' MsgBox NfName


' (your code here)


If colFiles.count > 0 Then
Set basebook = Workbooks.Add 'ThisWorkbook
For n = i To 1 Step -colFiles.count
Set mybook = Workbooks.Open(colFiles(n)) 'Search_path &
With mybook
For Each ws In Sheets
ws.copy after:=basebook.Sheets(basebook.Sheets.count)
With ActiveSheet '.UsedRange
If ws.Name Like " #" Or ws.Name Like " ##" Or ws.Name Like " #MW" Or ws.Name Like " ##MW" Then

Else
.Unprotect
.UsedRange.Value = .UsedRange.Value
'.UsedRange.ClearFormats
End If
End With
Next
With basebook
On Error Resume Next
MkDir ("D:\Data\11\" & NfName)
On Error GoTo 0
.Sheets(Array(1, 2, 3)).Delete '("Sheet1", "Sheet2", "Sheet3")
.SaveAs Filename:="D:\Data\11\" & NfName & "\" & mybook.Name & ".xlsx" 'Save
.Close 'SaveChanges:=True
End With
.Close SaveChanges:=False 'mybook
'Set mybook = Nothing
End With
Next n
.CutCopyMode = False
End If



Next



.DisplayAlerts = True
.ScreenUpdating = True
.CutCopyMode = False
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With


End Sub


Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)

Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant

'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop

If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop

'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If

End Function


Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function