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

问题场景

简述：
打开Summary.xlsm的文件，需要在此写一个VBA程序，读取一个指定文件夹的全部Excel，每个Excel的名称都变成Summary.xlsm的sheet名称，然后输入每个Excel的sheet名称到A列内（第一个单元格是列名"SheetsName"）。

---

代码描述

1. 获取指定文件夹中的所有Excel文件。
2. 对于每个Excel文件：
   • 创建一个新的sheet工作表，以文件名（不带扩展名）命名。
   • 在新工作表的A列中列出该Excel文件中的所有工作表名称。

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

---

注意事项

• 在运行这个宏之前，请确保Summary.xlsm文件已经打开并且有足够的权限访问指定的文件夹。

• 此代码也假设所有的Excel文件都有 .xls、.xlsx、.xlsm 等扩展名，如果有其他格式的Excel文件，需要调整 Like "xls*" 这一行代码来匹配它们。