目录
1，当前工作表保存为工作簿2，当前工作簿所有工作表保存为单独工作簿3，当前工作簿部分工作表保存为工作簿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 ActiveSheetIf 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_fileActiveWorkbook.Close (False)End WithApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueEnd 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 ActiveWorkbookIf 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 .Worksheetssht.Copy'ws在copy后自动生成一个新建wb'保存文件全名（文件路径、文件名、扩展名），sheet名称命名save_file = save_path & "\" & sht.Name & "." & fso.GetExtensionName(wb_name)ActiveWorkbook.SaveAs filename:=save_fileActiveWorkbook.Close (False)NextEnd WithApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueEnd 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 ActiveWorkbookIf 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 .Worksheetsm = Application.Match(sht.Name, ws, 0)If TypeName(m) = "Error" Theni = i + 1: ReDim Preserve arr(1 To i): arr(i) = sht.NameEnd IfNext.Worksheets(arr).Copy '其他工作表整体复制'保存文件全名（文件路径、文件名、扩展名）save_file = save_path & "\" & wb_name & "-新." & wb_name_exActiveWorkbook.SaveAs filename:=save_fileActiveWorkbook.Close (False)End WithApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueEnd Sub
