自动拆分EXCEL+工作表VBA

Sub NewWk()
    Dim Wb As Workbook
    Dim Sh As Worksheet

    Set Wb = ThisWorkbook
    Application.SheetsInNewWorkbook = 1
    Application.DisplayAlerts = False
    For Each Sh In Sheets
        Set Wb = Workbooks.Add
        Sh.Copy after:=Wb.Sheets(1)
        Wb.Sheets(1).Delete
        Wb.SaveAs ThisWorkbook.Path & “\” & Sh.Name & “.xls”
        Wb.Close
    Next
    Application.DisplayAlerts = True
    Application.SheetsInNewWorkbook = 3
End Sub

或

Sub A()
    Dim Wbk As Workbook
    Dim Sht As Worksheet
    For Each Sht In ThisWorkbook.Sheets
        Sht.Copy
        ActiveWorkbook.Close savechanges:=True, Filename:=ThisWorkbook.Path & “\” & Sht.Name & “.xls”
    Next
End Sub