Excel VBA小程序01-将多个sheet表另存为单独的工作薄文件并清除原表数据

具体步骤：

按Alt+F11，打开VBA编辑器，在代码窗口中粘贴代码。
然后关闭VBA编辑器，返回Excel界面，然后按Alt+F8打开“宏”对话框，选择对应宏执行即可。
这四段代码大同小异，实现不同功能本质上只替换代码主体即可。
以下代码将每个所选的工作表单独保存为一个工作簿，存放位置与原工作簿路径相同，名称为“工作表名称.xlsx”。

1、保存全部表格，保留全部格式

Sub Save_All()Dim Sh As WorksheetDim wb As WorkbookDim cPath$cPath = ThisWorkbook.Path & "\"Application.ScreenUpdating = FalseApplication.EnableEvents = FalseApplication.DisplayAlerts = False
' ----------------------------------------- 代码主体 -----------------------------------------For Each sht In ThisWorkbook.Worksheetssht.CopytheName = sht.Name & ".xlsx"ActiveWorkbook.SaveAs Filename:=cPath & "\" & theName, FileFormat:=xlNormalActiveWindow.CloseNext
' ----------------------------------------- 代码主体 -----------------------------------------Application.EnableEvents = TrueApplication.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub

2、保留特定表格，保留全部格式

Sub Save_Special_Sheet()Dim Sh As WorksheetDim wb As WorkbookDim cPath$cPath = ThisWorkbook.Path & "\"Application.ScreenUpdating = FalseApplication.EnableEvents = FalseApplication.DisplayAlerts = False
' ----------------------------------------- 代码主体 -----------------------------------------Sheets("特定表格1").SelecttheName = "特定表格1.xlsx"ActiveWorkbook.SaveCopyAs cPath & "\" & theNameSheets("特定表格2").SelecttheName = "特定表格2.xlsx"ActiveWorkbook.SaveCopyAs cPath & "\" & theName
'   ........
' ----------------------------------------- 代码主体 -----------------------------------------Application.EnableEvents = TrueApplication.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub

3、保留选中的表格，保留格式

执行代码前，需要将光标移至EXCEL底栏工作区，选择单独保存为工作簿的工作表。如果要选择多个工作表，可按Ctrl键或Shift键进行选择。

Sub Save_Select_Sheet()Dim Sh As WorksheetDim wb As WorkbookDim cPath$cPath = ThisWorkbook.Path & "\"Application.ScreenUpdating = FalseApplication.EnableEvents = FalseApplication.DisplayAlerts = False
' ----------------------------------------- 代码主体 -----------------------------------------For Each sht In ActiveWindow.SelectedSheetssht.CopytheName = sht.Name & ".xlsx"ActiveWorkbook.SaveAs Filename:=cPath & "\" & theName, FileFormat:=xlNormalActiveWindow.CloseNext
' ----------------------------------------- 代码主体 -----------------------------------------Application.EnableEvents = TrueApplication.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub

4、保存全部表格，不保留分表格式

Sub Save_All_Sheet_Value()Dim Sh As WorksheetDim wb As WorkbookDim cPath$, cFile$, nR1&, nR2&, Arr()cPath = ThisWorkbook.Path & "\"Application.ScreenUpdating = FalseApplication.EnableEvents = FalseApplication.DisplayAlerts = FalseFor Each Sh In WorksheetsnR1 = Sh.Range("a1048576").End(xlUp).RowIf nR1 > 1 ThenArr = Sh.Range("a2:z" & nR1).ValuecFile = Dir(cPath & Sh.Name & ".*")If cFile = "" ThenSet wb = Workbooks.AddWith wb.Sheets(1).Name = "汇总".SaveAs cPath & Sh.NameEnd WithElseWorkbooks.Open cPath & cFileSet wb = Workbooks(cFile)End IfWith wb.Sheets("汇总")nR2 = .Range("a1048576").End(xlUp).Row + 1.Range("a" & nR2).Resize(nR1 - 1, 26).Value = ArrIf .Range("a1").Value = "" ThenArr = Sh.Range("a1:z1").Value.Range("a1:z1").Value = ArrEnd IfEnd Withwb.Close (True)End IfNexApplication.EnableEvents = TrueApplication.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub

5、创建操作工作表，在另存为工作簿时不对该表进行操作。

主要就是在原有代码上加功能，表识别以Me.name开头。以代码4为例。
新建“汇总”表并创建宏按钮：

打开VB编辑窗口，将代码复制到“Sheet6（汇总）”表中，如下

Sub Save_All_Sheet_Value()Dim Sh As WorksheetDim wb As WorkbookDim cPath$, cFile$, nR1&, nR2&, Arr()cPath = ThisWorkbook.Path & "\"Application.ScreenUpdating = FalseApplication.EnableEvents = FalseApplication.DisplayAlerts = False
' ----------------------------------------- 代码主体 -----------------------------------------For Each Sh In WorksheetsIf Sh.Name <> Me.Name ThennR1 = Sh.Range("a1048576").End(xlUp).RowIf nR1 > 1 ThenArr = Sh.Range("a2:z" & nR1).ValuecFile = Dir(cPath & Sh.Name & ".*")If cFile = "" ThenSet wb = Workbooks.AddWith wb.Sheets(1).Name = "汇总".SaveAs cPath & Sh.NameEnd WithElseWorkbooks.Open cPath & cFileSet wb = Workbooks(cFile)End IfWith wb.Sheets("汇总")nR2 = .Range("a1048576").End(xlUp).Row + 1.Range("a" & nR2).Resize(nR1 - 1, 26).Value = ArrIf .Range("a1").Value = "" ThenArr = Sh.Range("a1:z1").Value.Range("a1:z1").Value = ArrEnd IfEnd Withwb.Close (True)End IfEnd IfNext
' ----------------------------------------- 代码主体 -----------------------------------------Application.EnableEvents = TrueApplication.ScreenUpdating = TrueApplication.DisplayAlerts = True
End Sub

6、选择是否要清楚原表数据

生成新的子表后会弹出选项“已生成新子表。清除各工作表数据吗？”

Sub Ask_Delete()Dim Sh As WorksheetDim wb As WorkbookDim cPath$, cFile$, nR1&, nR2&, Arr()cPath = ThisWorkbook.Path & "\"Application.ScreenUpdating = FalseApplication.EnableEvents = FalseApplication.DisplayAlerts = False
' ----------------------------------------- 代码主体 -----------------------------------------For Each Sh In WorksheetsIf Sh.Name <> Me.Name ThennR1 = Sh.Range("a1048576").End(xlUp).RowIf nR1 > 1 ThenArr = Sh.Range("a2:z" & nR1).ValuecFile = Dir(cPath & Sh.Name & ".*")If cFile = "" ThenSet wb = Workbooks.AddWith wb.Sheets(1).Name = "汇总".SaveAs cPath & Sh.NameEnd WithElseWorkbooks.Open cPath & cFileSet wb = Workbooks(cFile)End IfWith wb.Sheets("汇总")nR2 = .Range("a1048576").End(xlUp).Row + 1.Range("a" & nR2).Resize(nR1 - 1, 26).Value = ArrIf .Range("a1").Value = "" ThenArr = Sh.Range("a1:z1").Value.Range("a1:z1").Value = ArrEnd IfEnd Withwb.Close (True)End IfEnd IfNext
' ----------------------------------------- 代码主体 -----------------------------------------If MsgBox("已生成新子表。清除各工作表数据吗？      ", 36, "提示") = 6 ThenFor Each Sh In WorksheetsIf Sh.Name <> Me.Name Then Sh.Range("a2:z1048576").ClearContentsNextThisWorkbook.SaveEnd If
End Sub

参考：

1、Excel VBA-批量将多个sheet表另存为单独的工作薄文件，Crystal_Data

Excel VBA小程序01-将多个sheet表另存为单独的工作薄文件并清除原表数据相关推荐

Excel VBA-批量将多个sheet表另存为单独的工作薄文件
将excel多个工作表另存为单独的工作薄工作中为了方便,我们常常将多个数据类似的表放在同一个工作薄,但是如果要对每个文件执行相同的转换或处理,需要用R或Python读取每张表的数据,这时就要将其拆分 ...
Excel VBA小程序03-快速提取单元格中的数字和非数字
0.表格内容 A列 B列手机2134 型号324 2135手机 325型号 2手机136 32型号6 1.Word法 1.1 提取非数字遇事不决就去隔壁找Word,将表格A列内容复制到Word中, ...
Excel VBA小程序-如何快速将整个工作簿的公式转换为数值
根据操作范围,这可以分为三种情况. ❶多工作表公式转数值 ❷多工作簿公式转数值 1.多工作表公式转数值如果是将当前工作簿所有工作表的公式转换为数值,需要使用到VBA代码. Sub FunctionT ...
Excel VBA小程序 -批量合并和撤销合并单元格
合并单元格之前要提前将数据列排序好,然后再复制以下代码,运行宏程序. 批量合并单元格 Sub RngMergeCondition() '批量合并单元格Dim rngUser As RangeDim r ...
Excel VBA 小程序 - 文本型数字转为数值型数字
实现功能:选中当前工作表中的所有数据内容,将文本型数字转换为数值型数字. 缺点:日期格式的字符串会变成数值 Sub 转数值型数字() With ActiveSheet.UsedRange.Number ...
VBA小程序--针对所有已经打开的Excel文件_格式调整_针对所有工作表_冻结首行_无视所在位置
VBA小程序--针对所有已经打开的Excel文件_格式调整_针对所有工作表_冻结首行_无视所在位置 Function 格式调整_针对所有工作表_冻结首行_无视所在位置()Dim sht As Work ...
wps vba模块压缩包_01_创建第一个VBA小程序：你好，世界
大家好,我是一可赛二(Excel),EXCEL VBA爱好者,在这里分享我学习VBA的过程. 目录第一节什么是EXCEL VBA(宏) 第二节在EXCEL界面上调出"开发工具" ...
VBA小程序_对于选中的单元格进行取消合并_选择空值向上填充
Sub VBA小程序_对于选中的单元格进行取消合并_选择空值向上填充()Dim a As RangeSet a = Selection '定义变量为最初选择的区域,不忘初心Selection.UnMe ...
VBA小程序_遍历所有工作表_复制粘贴为数值
Sub VBA小程序_遍历所有工作表_复制粘贴为数值()Dim sht As WorksheetFor Each sht In Worksheetssht.Activatesht.Cells.Copy ...