查找并列出目录中所有工作簿的工作表 - 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