通过VBA将一个工作簿中的多个工作表拆分为多个工作簿,以工作表名称命名工作簿

前提：电脑上装有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

以上就是大致的拆分情况。