Microsoft Excel VBA 输出文件夹内全部Excel内的sheet

    Sub ListSheets()
    Dim FileSystem As Object
    Dim Folder As Object
    Dim File As Object
    Dim SourceWorkbook As Workbook
    Dim SourceSheet As Worksheet
    Dim wbCheck As Workbook
    Dim wsSummary As Worksheet
    Dim NewSheet As Worksheet
    
    Dim FolderPath As String
    Dim FileName As String
    Dim FileNameCell As Range
    Dim SheetNameCell As Range
    Dim i As Integer
    Dim SheetIndex As Integer
    
    ' 设置要扫描的文件夹路径
    FolderPath = "C:\Folder\Path" ' 修改文件夹路径
    
    ' 确保文件夹路径以反斜杠结束
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
    
    ' 设置wbCheck 为当前活动的工作簿
    Set wbCheck = ThisWorkbook
    
    ' 创建FileSystemObject
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    Set Folder = FileSystem.GetFolder(FolderPath)
    
    ' 找到名称为"FileName"的单元格
    On Error Resume Next ' 如果未找到名称定义，避免错误
    Set FileNameCell = ws.Range("FileName")
    On Error GoTo 0 ' 重新启用错误报告
    
    ' 如果找不到名称定义，则退出宏
    If FileNameCell Is Nothing Then
        MsgBox "The range name 'FileName' is not defined.", vbExclamation, "Range Name Not Found"
        Exit Sub
    End If
    
    ' 从"FileName"单元格下一行开始
    i = FileNameCell.Row + 1
    
    ' 遍历文件夹中的每个Excel文件
    For Each File In Folder.Files
        If LCase(FileSystem.GetExtensionName(File.Path)) Like "xls*" Then
    			' 文件名称写入Excel中
    			wsSummary.Cells(i, FileNameCell.Column).Value = FileName = FileSystem.GetBaseName(File.Path)
            ' 在wbCheck 中创建一个新的工作表
            Set NewSheet = wbCheck .Sheets.Add(After:=wbCheck .Sheets(wbCheck .Sheets.Count))
            NewSheet.Name = FileName
    
            ' 打开源Excel文件
            Set SourceWorkbook = Workbooks.Open(File.Path)
    
            ' 列出源Excel文件中的所有工作表名称
            SheetIndex = 1
            For Each SourceSheet In SourceWorkbook.Sheets
                NewSheet.Cells(SheetIndex, 1).Value = SourceSheet.Name
                SheetIndex = SheetIndex + 1
            Next SourceSheet
    
            ' 关闭源Excel文件
            SourceWorkbook.Close SaveChanges:=False
           
            i = i + 1
        End If
    Next File
    
    ' 清理
    Set File = Nothing
    Set Folder = Nothing
    Set FileSystem = Nothing
    Set SourceWorkbook = Nothing
    Set SourceSheet = Nothing
    Set NewSheet = Nothing
    End Sub