查找和列出目录中所有工作簿的工作表-Excel，VBA

Question

我目前正在尝试从目录中的多个工作簿编译工作表的所有名称的列表。 到目前为止，我已经找到并编辑了一些代码（请参见下文），这些代码将为我提供所需的结果，但一次只提供一本工作簿。 我需要轻松提取400本工作簿，而我正在努力使这一工作更聪明而不是更努力。 不幸的是，这些工作簿可以存储在目录中的任何文件夹或子文件夹中，唯一的一致性是它们是唯一的.xlsm文件。 有没有办法做到这一点，并在单独的列中列出每个工作簿的工作表标题？ 任何帮助，不胜感激！

    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

尝试下面的子。 希望对您有帮助。

    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