将.xlsx内sheet拆分成新的.xlsx

Sub ExtractSheets()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim newWs As Worksheet
    Dim filePath As String
    Dim fileName As String
    Dim sheetName As String
    
    'Open folder dialog to select folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        filePath = .SelectedItems(1)
    End With
    
    'Loop through all files in folder
    fileName = Dir(filePath & "\*.xlsx")
    Do While fileName <> ""
        Set wb = Workbooks.Open(filePath & "\" & fileName)
        
        'Loop through all sheets in workbook
        For Each ws In wb.Sheets
            sheetName = ws.Name
            
            'Create new workbook and copy sheet to it
            Set newWb = Workbooks.Add
            Set newWs = newWb.Sheets(1)
            ws.Copy newWs
            
            'Save new workbook with same name as sheet
            newWb.SaveAs filePath & "\" & sheetName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            
            'Close new workbook
            newWb.Close False
        Next ws
        
        'Close original workbook
        wb.Close False
        
        'Get next file name
        fileName = Dir
    Loop
End Sub