当前目录下的所有EXCEL文件中的sheet名字读取并写入到一个新的EXCEL工作簿的每一列中，便于查看sheet名是否相同

​

Sub ListSheetNames()
    Dim fso As Object, folder As Object, file As Object
    Dim wb As Workbook, ws As Worksheet, newWs As Worksheet
    Dim i As Integer, j As Integer
    Dim currentFileName As String
    currentFileName = ThisWorkbook.Name '获取当前工作簿文件名

'检查是否存在SheetNamesList工作表，如果存在则删除
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Sheets("SheetNamesList").Delete
Application.DisplayAlerts = True
On Error GoTo 0

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(ThisWorkbook.Path)
Set newWs = ThisWorkbook.Sheets.Add
newWs.Name = "SheetNamesList"
i = 1
j = 1

For Each file In folder.Files
    If LCase(Right(file.Name, 4)) = ".xls" Or LCase(Right(file.Name, 5)) = ".xlsx" Then
        If file.Name <> currentFileName Then '排除当前工作簿
            newWs.Cells(1, j).Value = file.Name
            Set wb = Workbooks.Open(file.Path)
            i = 2
            For Each ws In wb.Worksheets
                newWs.Cells(i, j).Value = ws.Name
                i = i + 1
            Next ws
            wb.Close False
            j = j + 1
        End If
    End If
Next file

Set fso = Nothing
Set folder = Nothing
End Sub