Excel·VBA工作簿工作表拆分保存为工作簿

1，当前工作表保存为工作簿

Sub 当前工作表保存为工作簿()
    '注意：存在同名文件会被替换
    Dim fso As Object, save_path$, save_file$, wb_name$
    save_path = ""  '拆分后的表格保存路径，为空则保存至固定路径
    Set fso = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    
    With ActiveSheet
        If save_path = "" Then save_path = .Parent.path + "\拆分表"  'save_path未定义则为固定路径
        wb_name = .Parent.Name  '当前工作簿文件名和扩展名
        If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
        .Copy    'ws在copy后自动生成一个新建wb
        '保存文件全名（文件路径、文件名、扩展名），sheet名称命名
        save_file = save_path & "\" & .Name & "." & fso.GetExtensionName(wb_name)
        ActiveWorkbook.SaveAs filename:=save_file
        ActiveWorkbook.Close (False)
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

2，当前工作簿所有工作表保存为单独工作簿

对Excel活动工作簿进行拆分，每个工作表单独保存为工作簿文件，文件保存在该工作簿同一文件夹下单独文件夹内

Sub 工作簿所有工作表拆分为单独工作簿()
    '将活动工作簿wb拆分，每个ws单独保存为文件，文件保存在wb同一文件夹下单独文件夹内
    Dim fso As Object, save_path$, save_file$, wb_name$
    save_path = ""  '拆分后的表格保存路径，为空则保存至固定路径
    Set fso = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    '''注意：当存在ws与wb同名时，SaveAs会报错
    With ActiveWorkbook
        If save_path = "" Then save_path = .path + "\拆分表"  'save_path未定义则为固定路径
        wb_name = .Name  '当前工作簿文件名和扩展名
        If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
        For Each sht In .Worksheets
            sht.Copy     'ws在copy后自动生成一个新建wb
            '保存文件全名（文件路径、文件名、扩展名），sheet名称命名
            save_file = save_path & "\" & sht.Name & "." & fso.GetExtensionName(wb_name)
            ActiveWorkbook.SaveAs filename:=save_file
            ActiveWorkbook.Close (False)
        Next
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

3，当前工作簿部分工作表保存为工作簿

Sub 工作簿部分工作表保存为工作簿()
    '将活动工作簿wb拆分，除指定名称外的其他工作表拆分为一个工作簿；注意：存在同名文件会被替换
    Dim fso As Object, save_path$, save_file$, wb_name$, ws, arr(), m, i&
    save_path = ""  '拆分后的表格保存路径，为空则保存至固定路径
    ws = Array("Sheet1")  '需要排除的指定名称工作表
    Set fso = CreateObject("Scripting.FileSystemObject")
    Application.ScreenUpdating = False  '关闭屏幕更新，加快程序运行
    Application.DisplayAlerts = False   '不显示警告信息
    With ActiveWorkbook
        If save_path = "" Then save_path = .path + "\拆分表"  'save_path未定义则为固定路径
        wb_name = fso.GetBaseName(.Name)  '当前工作簿文件名
        wb_name_ex = fso.GetExtensionName(.Name)  '扩展名
        If Not fso.FolderExists(save_path) Then fso.CreateFolder (save_path)  '创建文件夹
        For Each sht In .Worksheets
            m = Application.Match(sht.Name, ws, 0)
            If TypeName(m) = "Error" Then
                i = i + 1: ReDim Preserve arr(1 To i): arr(i) = sht.Name
            End If
        Next
        .Worksheets(arr).Copy  '其他工作表整体复制
        '保存文件全名（文件路径、文件名、扩展名）
        save_file = save_path & "\" & wb_name & "-新." & wb_name_ex
        ActiveWorkbook.SaveAs filename:=save_file
        ActiveWorkbook.Close (False)
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub