如：123.xlsx 含有三个sheet分别为a、b、c；拆分成 a.xlsx 、b.xlsx 、 c.xls ，拆分后的a.xls、 b.xls、 c.xls含有相同名称的sheet
----代码如下1：
Sub SplitWorkBook_sht() '把工作簿中的多个sheet页拆分成多个工作簿
Dim sht As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In Sheets
sht.Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "测试1" & sht.Name
ActiveWorkbook.Close
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
----代码如下2：
Sub SplitWorkBook_ws() '把xxx.把工作簿中的多个sheet页拆分成多个工作簿
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
ws.Copy
Workbooks(Workbooks.Count).SaveAs ThisWorkbook.Path & "\" & "测试2" & ws.Name
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub
--代码如下1（通过某一列sheet页的分类值来拆分成sheet页）：
Sub 拆分表()
Application.ScreenUpdating = False
Dim clm_d, hh As Integer
Dim mycell As Range
Dim nodupes As New Collection
Dim rngop As Range
Set shtop = ActiveSheet
hh = Application.CountA(Range("1:1")) '计算第1行单元格数：=counta(1:1)
MsgBox "第1行单元格数："& hh '查看变量值
clm_d = Application.InputBox(prompt:="请选择作为拆分的sheet页列" & Chr(13) _
& "注意:" & Chr(13) & "1、拆分第一行为标题行" & Chr(13) & "2、输入sheet页名称列号数字", Type:=1)
If clm_d = False Or clm_d > hh Then Exit Sub
On Error Resume Next
For Each mycell In shtop.Range(Cells(4, clm_d), (shtop.Cells(4, clm_d).End(xlDown)))
nodupes.Add mycell.Value, CStr(mycell.Value)
Next mycell
On Error GoTo 0
Set rngop = Cells.CurrentRegion
For Each Item In nodupes
rngop.AutoFilter Field:=clm_d, Criteria1:=Item
rngop.Copy
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = Item
ActiveSheet.Paste
Next Item
rngop.AutoFilter
shtop.Activate
Application.ScreenUpdating = True '开启屏幕刷新
End Sub
