Macro to list all worksheets in a folder and subfolder - vba

Question

I have been trying to write some code that will dig in to each folder and subfolder in a directory to list the names of the worksheets in my workbooks. After much time and help from the posts on this forum, I have gotten this far but still do not have a working macro. I'm sure it's obvious, and I apologize for the gore, but does anyone have any idea why it is not working? Thanks!
Option Explicit
Sub marines()
Dim FileSystem As Object
Dim HostFolder As String
Dim OutputRow
OutputRow = 2
HostFolder = "G:\EP\Projects\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
Dim Workbook As Variant
Dim wb As Workbook
Dim ws As Worksheet
Dim HostFolder
Dim OutputRow
OutputRow = 2
FileType = "*.xls*"
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
For Each Workbook In Folder.SubFolders
ThisWorkbook.ActiveSheet.Range("A" & OutputRow).Activate
OutputRow = OutputRow + 1
Curr_File = Dir(HostFolder & FileType)
Do Until Curr_File = ""
For wb = wb.Open(HostFolder & Curr_File, False, True)
ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = ThisWorkbook.Name
ThisWorkbook.ActiveSheet.Range("B" & OutputRow).ClearContents
OutputRow = OutputRow + 1
Set Each ws In wb.Sheets
ThisWorkbook.ActiveSheet.Range("B" & OutputRow) = ws.Name
ThisWorkbook.ActiveSheet.Range("A" & OutputRow).ClearContents
OutputRow = OutputRow + 1
Next ws
wb.Close SaveChanges:=False
Next
End Sub

Answer 1

I see you have a reference to Microsoft Scripting Runtime so I'll skip that part.
Simple solution: A module to withdraw all the workbooks in a folder and subfolders recursively and add them to a collection:
Public Sub ExtractAllWorkbooks(ByVal Addr As String, ByRef coll As Collection)
DoEvents
Dim objFSO As New FileSystemObject
Dim objFile As File, objFolder As Folder, objSubFolder As Folder
Set objFolder = objFSO.GetFolder(Addr)
For Each objFile In objFolder.Files
If Right(objFile.Name, 5) = ".xlsx" And Left(objFile.Name, 1) <> "~" Then
Call addStringToCollection(objFile.Path, coll)
End If
Next
For Each objSubFolder In objFolder.SubFolders
Call ExtractAllWorkbooks(objSubFolder.Path, coll)
Next
End Function
Public Sub addStringToCollection(stringToAdd As String, coll As Collection)
Dim st As String
For i = 1 To coll.Count
st = coll.Item(i)
If st = stringToAdd Then Exit Sub
Next
coll.Add stringToAdd
End Sub
With that, you just need to run in your main module:
dim Coll as New Collection
Const Addr As String = "G:\EP\Projects\"
Call ExtractAllWorkbooks(Addr, Coll)
Now you should have all the workbooks listed in the collection Coll. Just got to open them up and withdraw the worksheets' names elsewhere. Something like this should do the trick, assuming you are exporting the results to the worksheet wsRef:
dim wb as Workbook, ws as Worksheet
i = 2
For each st in coll
Set wb = Workbooks.Open(st)
For Each ws in wb.Worksheets
wsRef.Cells(i, 1) = wb.Name
wsRef.Cells(i, 2) = ws.Name
i = i + 1
Next
Application.DisplayAlerts = False
wb.Close
Application.DisplayAlerts = True
Next