将sheet工作表批量另存为独立的工作簿，并命名成sheet表的名称
 用法：打开excel文档，按ALT+F11调出VB编辑器，点插入模块，粘贴代码，按F5运行即可。
 Sub saveworkbook()        '将sheet工作表批量另存为独立的工作簿，并命名成sheet表的名称
 Dim sht As Worksheet     '定义字符变量
 Application.ScreenUpdating = False     '关闭屏幕更新
 ipath = ThisWorkbook.Path & '\'          '指定建立新的工作簿保存到的路径
 For Each sht In Sheets       '遍历所有的sheet工作表
    sht.Copy     ' 拷贝sheet工作表到新的工作簿，即将工作表另存为新的文件。
    ActiveWorkbook.SaveAs ipath & "\" & sht.Name & ".xlsx"  '保存工作簿，并命名成工作表的名称
    ActiveWorkbook.Close         '关闭工作表
    Next '执行遍历循环体
 Application.ScreenUpdating = True   '开启屏幕更新
 End Sub
 ------------以下为实测成功代码-----------
 Sub saveworkbook()
 Dim sht As Worksheet
 Application.ScreenUpdating = False
 ipath = ThisWorkbook.Path & "\"
 For Each sht In Sheets
    sht.Copy 
    ActiveWorkbook.SaveAs ipath & sht.Name
    ActiveWorkbook.Close
    Next
 Application.ScreenUpdating = True
 End Sub

SUB 批量增加命名工作表()
 For L = 1 To 100
Sheets.Add(, Sheets("发票表头")).Name = "发票表" & i
NEXT

END SUB

SUB 批量删除工作表()
Application.DisplayAlerts = 0  ‘’‘关闭提示
On Error Resume Next
X = Worksheets.Count
For i = 1 To X 

Worksheets("发票表" & i).Delete
Next
Application.DisplayAlerts = 1
MsgBox ("完成" & X - 3 & "个工作表删除!")
end SUB

前提：电脑上装有office2007或office2013等，WPS不行。
 
1、如果你有现成的一个工作簿含有多个工作表的文件，想分成多个工作簿的话，
 可以通过office2007或office2013等打开execl，然后通过execl里面的开发工具，
 输入以下运行代码，执行就行（拆分的工作簿在你设置的路径下）：
 
 
 
Sub cfb()
 Dim m As Integer
 Dim sht, sht1 As Worksheet
 '按照需要将分出来的表分成多个工作簿
 n = InputBox(“请输入excel的路径”)
 For Each sht1 In Sheets
 sht1.Copy
 ActiveWorkbook.SaveAs Filename:=n & “” & sht1.Name & “.xlsx”
 ActiveWorkbook.Close
 Next
 End Sub
 
 
2、如果你的工作簿里只有一个工作表，但是需要根据工作表中的某个字段拆分成多个工作簿，并且以该字段值命名工作簿的话，输入以下运行代码，执行就行（拆分的工作簿在你设置的路径下）：
 
 
 
Sub cfb()
 Dim i, j, k, l, m As Integer
 Dim sht, sht1 As Worksheet
 m = InputBox(“想按照第几列分表!”)
 '分表前先删除多余表（将需要的工作表放最前方就行）
 Application.DisplayAlerts = False
 If Sheets.Count > 1 Then
 For i = Sheets.Count To 2 Step -1
 Sheets(i).Delete
 Next
 End If
 '通过字段名进行建表,注意需要建表的字段不能违反表名规则
 j = Sheet1.Range(“a65536”).End(xlUp).Row
 For i = 2 To j
 k = 0
 For Each sht In Sheets
 If sht.Name = Sheet1.Cells(i, m) Then
 k = 1
 End If
 Next
 If k = 0 Then
 Sheets.Add after:=Sheets(Sheets.Count)
 Sheets(Sheets.Count).Name = Sheet1.Cells(i, m)
 End If
 Next
 '通过已知到的表名进行数据筛选赋值拷贝数据
 For l = 2 To Sheets.Count
 Sheet1.Range(“a1:iv65536”).AutoFilter Field:=m, Criteria1:=Sheets(l).Name
 Sheet1.Range(“a1:iv65536”).Copy Sheets(l).Range(“a1”)
 Next
 Sheet1.Range(“a1:iv65536”).AutoFilter
 '按照需要将分出来的表分成多个工作簿
 m = InputBox(“是否需要分成多个工作簿：1.是，2.否”)
 If m = 1 Then
 n = InputBox(“请输入excel的路径”)
 For Each sht1 In Sheets
 sht1.Copy
 ActiveWorkbook.SaveAs Filename:=n & “” & sht1.Name & “.xlsx”
 ActiveWorkbook.Close
 Next
 End If
 End Sub
 
 
3、如果你有现成的一个工作簿含有多个工作表的文件，想分成多个工作簿，并且有隐藏工作表时，弹出输入框，选择是否执行或显示当前隐藏的工作表。输入以下运行代码，执行就行（拆分的工作簿在当前目录的"拆分"文件夹中）：
 
 
 
Sub cfb()
 Application.ScreenUpdating = False
 Dim xpath, isNext As String
 Dim sht As Worksheet
 xpath = Application.ActiveWorkbook.Path & “\拆分”
 '如果文件夹不存在，则新建文件夹
 If Len(Dir(xpath, vbDirectory)) = 0 Then MkDir xpath
 For Each sht In Worksheets
 If sht.Visible = False Then
 'MsgBox “有隐藏工作表” & sht.Name
 '隐藏工作表是否拆分
 isNext = InputBox(“1:跳过不处理” & Chr(10) & “2:处理” & Chr(10) & “空:默认不处理”, “【” & sht.Name & “】为隐藏工作表,请选择执行方式”)
 If isNext = “2” Then
 sht.Visible = True '取消工作表的隐藏
 sht.Copy
 ActiveWorkbook.SaveAs Filename:=xpath & “” & sht.Name & “.xlsx”
 ActiveWorkbook.Close
 sht.Visible = False '恢复工作表的隐藏
 End If
 ElseIf sht.Visible = True Then
 sht.Copy
 ActiveWorkbook.SaveAs Filename:=xpath & “” & sht.Name & “.xlsx”
 ActiveWorkbook.Close
 End If
 Next
 'MsgBox “工作簿拆分完成”
 Application.ScreenUpdating = True '恢复屏幕更新
 End Sub
 
 
以上就是大致的拆分情况。

一、需求
 
根据sheet1所列名称，添加并重命名新的工作表。
 
 
二、实现
 
1.按照从前往后的顺序
 
Sub cre_ren_sheets()
	Dim num% 
	/* 定义为integer*/
	num = Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
	/* num是非空单元格数*/
	
	For i = 1 To num
	    Sheets.Add after:=ActiveSheet
	    Sheets(i + 1).Select
	    Sheets(i + 1).Name = Sheet1.Cells(i, 1)
	Next i
End Sub
 
 
2.按照从后往前的顺序
 
Sub cre_ren_sheets()
	Dim num%
	num = Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
	
	For i = 1 To num
	    Sheets.Add
	    Sheets(1).Name = Sheet1.Cells(i, 1)
	    /* Sheet1=Sheets(i+1)， sheet1随着新工作表的建立被往后挤，序列数随之增大*/
	Next i
End Sub

 
 
三、注意事项
 
1.代码中的索引号和新建sheet默认命名不一定一致，代码按照顺序，工作簿只是名称。
 
 
2.工作表的命名要求