How can I open all excel files in a folder and its sub folders

[philqw78]

I get sent a folder containing zip files. I extract the zips to another folder. This then gives me 65 sub folders(directo ries), each with an excel and a text file. I wish to open all the excel files with one action in VB. If possible put them all on a single sheet in one workbook. They are all formatted the same and do not contain a lot of data so size and formatting will not be a problem.
I have

Sub Open_My_Files()
Dim MyFile As String
MyPath = "C:\Temp\Unzipped"
MyFile = Dir(MyPath)

Do While MyFile <> ""
If MyFile Like "*.xls" Then
Workbooks.Open MyPath & MyFile
End If
MyFile = Dir
Loop
End Sub

to extract from a single folder. I need to get it out of sub folders though.
Can anyone please help?

[debasisdas]

What about copying / moving all the files to a single location.

[philqw78]

What about copying / moving all the files to a single location.

Because it would be faster to open them individually. I want to open 65 files quickly and copy them all to the same sheet.

[Guido Geurs]

This goes to a folder and search each subfolder for an XLS file.
You have to add the reference= Microsoft Scripting Runtime
(c:\windows\sys tem32\scrrun.dl l)

Private Sub Com_all_files_and_subs_Click()
Dim FSO As New FileSystemObject
Dim START_FOLDER As Folder
Dim MyPath As String
   MyPath = "C:\Temp\Unzipped"
   MousePointer = 11
   On Error GoTo Error_Files
   Set START_FOLDER = FSO.GetFolder(MyPath)
   Call Open_Files(START_FOLDER) '§ must be a function because it calls it's own
   MousePointer = 0
Exit Sub
Error_Files:
   MsgBox ("Error folder")
   MousePointer = 0
End Sub

Private Function Open_Files(ByVal START_FOLDER)
Dim MyFile As File
Dim SUBFOLDER As Folder
   For Each MyFile In START_FOLDER.Files
      On Error GoTo Volgende
      Text1.Text = Text1.Text & MyFile & vbNewLine
      If MyFile Like "*.xls" Then
      Workbooks.Open MyFile
      End If
Volgende:
   Next
   For Each SUBFOLDER In START_FOLDER.SubFolders
      Call Open_Files(SUBFOLDER)
   Next
End Function

[philqw78]

Guido, a couple of problems. VB is not one of my strengths and I have little understanding of it.
What do I have to do for this

You have to add the reference= Microsoft Scripting Runtime
(c:\windows\sys tem32\scrrun.dl l)

Also this is "Private Sub " so it does not show on my list of available macros. I can change it to "Sub" then it does appear but I then get the error

Compile error

User defined type not defined

and this code is highlighted on the debug

Dim FSO As New FileSystemObject

Also this is in excel 2007, if that makes a difference

[Guido Geurs]

This is tested in VBA Excel 2003
Q1: how to add Reference:(see gif's)
In VBA: click "Tools" - "References "
Select: Microsoft Scripting Runtime
Q2: The error is because the Reference is not added.

Attached is a demo sheet.

PS: if it does not work in 2007, please let me know.

[philqw78]

Thanks a lot Guido. I figured out the Tools and References but could not get the Private sub to run without your User Form. Works a treat in 2007.

Now for my next question, can VB copy all the first sheets in those books opened to a single sheet in a new workbook?

I'll start working on it but you will probably beat me to the answer.

Thanks again

[philqw78]

I have so far managed

Sub CopyALL()
ActiveSheet.Range("A1").CurrentRegion.Offset(1).Resize(Range("A1").CurrentRegion.Rows.Count - 1).Copy _
 Destination:=Workbooks("copybook.xlsm").Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
ActiveWorkbook.Close False

End Sub

Now I just need to get it to loop through this in your code Guido, if its possible. At the moment I have just associated it to a shortcut key so that I just keep pressing ctrl+g until I'm back to the "copybook" sheet where all the copies are.

[edit]Cracked it, goes between lines 24 and 25 of your code. Works a treat thanks[/edit]

[Guido Geurs]

this wiil collect all the first sheets and dump it in the workbook with the macro:(see also attachment)

Private Sub Com_all_files_and_subs_Click()
Dim FSO As New FileSystemObject
Dim START_FOLDER As Folder
Dim MyPath As String
Dim WORKBOOKSidx As Integer
Dim ARRCOLLECT As Variant
   MyPath = "C:\Temp\Unzipped"
   MousePointer = 11
   On Error GoTo Error_Files
   Set START_FOLDER = FSO.GetFolder(MyPath)
   Call OPEN_FILES(START_FOLDER) '§ must be a function because it calls it's own
   For WORKBOOKSidx = 2 To Workbooks.Count
      Workbooks(WORKBOOKSidx).Activate
      Sheets(1).Activate
      ReDim ARRCOLLECT(0) '§ clear array
      '§ set sheet1 to array
      ARRCOLLECT = Range("A1").Resize(Range("A1").End(xlDown).Row, _
                                 Range("A1").End(xlToRight).Column)
      '§ dump array in sheet "collect"
      Workbooks(1).Activate
      Sheets(1).Activate
      If Range("A1") = "" Then '§ blanco sheet
         Range("A1").Resize(UBound(ARRCOLLECT, 1), _
                           UBound(ARRCOLLECT, 2)) = ARRCOLLECT
      Else
         Range("A" & Range("A1").End(xlDown).Row + 1). _
                        Resize(UBound(ARRCOLLECT, 1), _
                              UBound(ARRCOLLECT, 2)) = ARRCOLLECT
      End If
   Next
   MousePointer = 0
Exit Sub
Error_Files:
   MsgBox ("Error folder")
   MousePointer = 0
End Sub
  
Private Function OPEN_FILES(ByVal START_FOLDER)
Dim MyFile As File
Dim SUBFOLDER As Folder
   For Each MyFile In START_FOLDER.Files
      On Error GoTo Volgende
      Text1.Text = Text1.Text & MyFile & vbNewLine
      If MyFile Like "*.xls" Then Workbooks.Open MyFile
Volgende:
   Next
   For Each SUBFOLDER In START_FOLDER.SubFolders
      Call OPEN_FILES(SUBFOLDER)
   Next
End Function