当前工作簿中的每个工作表拆分到单独的工作簿

Sub SplitWorkbookToWorksheets()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim newWb As Workbook
    Dim newWs As Worksheet
    Dim FilePath As String
    Dim FileName As String
    
    Set wb = ThisWorkbook '当前工作簿路径
    FilePath = "C:\SavePath\" '拆分后的工作簿保存路径
    
    Application.ScreenUpdating = False '关闭屏幕刷新
    
    '循环遍历每个工作表
    For Each ws In wb.Worksheets
        '创建一个新工作簿
        Set newWb = Workbooks.Add
        '将当前工作表复制到新工作簿
        ws.Copy Before:=newWb.Sheets(1)
        '删除新工作簿中的其他工作表
        For Each newWs In newWb.Worksheets
            If newWs.Name <> ws.Name Then
                Application.DisplayAlerts = False
                newWs.Delete
                Application.DisplayAlerts = True
            End If
        Next newWs
        
        '保存新工作簿
        FileName = FilePath & ws.Name & ".xlsx"
        newWb.SaveAs FileName
        newWb.Close
    Next ws
    
    Application.ScreenUpdating = True '重新开启屏幕刷新
    
    MsgBox "拆分完成！"
End Sub

使用该代码时，需要将FilePath变量修改为你想要保存的路径。此代码会将当前工作簿中的每个工作表拆分到单独的工作簿，并以原工作表名命名新工作簿，保存在指定路径下。