Find and List Sheets for All Workbooks in a Directory- Excel, VBA

Question

I am currently trying to compile a list of all the names of the Worksheets from multiple Workbooks in a directory. So far, I have found and edited some code (see below) that will give me the desired result, but just for one Workbook at a time. There are easily 400 workbooks I need to pull from, and I'm trying to work a bit smarter rather than harder on this one. Unfortunately, these Workbooks could be stored in any folder or subfolder in the directory, with the only consistency being that they are the only .xlsm files. Would there be a way to do this and have each Workbook's Worksheet titles listed in separate columns? Any help greatly appreciated!!

    Sub ListSheets()

'enter my directory
    Workbooks.Open Filename:="path"
    Dim ws As Worksheet
    Dim i As Integer
    With ThisWorkbook.Worksheets("Sheet1")
    .Range("a:a").ClearContents
    For Each ws In ActiveWorkbook.Worksheets
    i = i + 1
    .Range("a" & i) = ws.Name
    Next ws
    End With
'Enter my workbook below
    Workbooks("").Close True

    End Sub

Answer 1

Try following sub. Hope it will help you.

    Sub EachSHinEachBook()
    Dim FolderNme As String
        FileType = "*.xls*"     'The file type to search for
        OutputRow = 2   'The first row of the active sheet to start writing to                 

        filepath = "C:\MyExcelFiles\" 'The folder to search

        ThisWorkbook.ActiveSheet.Range("A" & OutputRow).Activate
        OutputRow = OutputRow + 1
        Curr_File = Dir(filepath & FileType)
        Do Until Curr_File = ""
            Set FldrWkbk = Workbooks.Open(filepath & Curr_File, False, True)
            ThisWorkbook.ActiveSheet.Range("A" & OutputRow) = Curr_File
            ThisWorkbook.ActiveSheet.Range("B" & OutputRow).ClearContents   'Clear any previous values
            OutputRow = OutputRow + 1

            For Each Sht In FldrWkbk.Sheets
                ThisWorkbook.ActiveSheet.Range("B" & OutputRow) = Sht.Name
                ThisWorkbook.ActiveSheet.Range("A" & OutputRow).ClearContents 'Clear any previous values
                OutputRow = OutputRow + 1
            Next Sht
            FldrWkbk.Close SaveChanges:=False
            Curr_File = Dir
        Loop
        Set FldrWkbk = Nothing
    End Sub