玖叶教程网

将以下代码保存到待拆分的工作簿的模块中，运行后即可执行拆分，对于保存位置，以下两个过程分别以不同的方式指定：

1 以原工作簿的名字新建一文件夹，然后将拆分后的工作表做为工作簿保存到新文件夹中：

Sub 拆分工作簿()
 On Error Resume Next
 Dim fso As Object
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim i As Integer
 Set wb = ThisWorkbook
 Dim str As String
 Dim lens As Integer
 lens = VBA.InStr(wb.Name, ".")
 str = VBA.Left(wb.Name, lens)
 Set fso = CreateObject("Scripting.FileSystemObject")
 If fso.FolderExists(ThisWorkbook.path & "\" & str) = True Then
 MsgBox "文件夹已存在"
 Exit Sub
 Else
 MkDir ThisWorkbook.path & "\" & str
 End If
 For i = 1 To wb.Worksheets.Count
 Set ws = wb.Worksheets(i)
 ws.Copy
 ActiveWorkbook.SaveAs Filename:=ThisWorkbook.path & "\" & str & "\" & ws.Name & ".xlsx" '不能指定不存在的工作路径
 Debug.Print ThisWorkbook.path & "\" & str & "\" & ws.Name & ".xlsx"
 ActiveWorkbook.Close
 Next
 Set ws = Nothing
 Set wb = Nothing
End Sub

2 打开文件夹对话框，指定要保存的路径或新建文件夹所在路径

Sub 拆分工作簿2() 
 On Error Resume Next
 Dim fd As FileDialog, path As String, sht As Worksheet
 '弹出对话框，让用户选择文件夹
 Set fd = Application.FileDialog(msoFileDialogFolderPicker)
 '如果选择了文件夹则记录地路径
 If fd.Show = -1 Then
 path = fd.SelectedItems(1) & IIf(Right(fd.SelectedItems(1), 1) = "\", "", "\")
 Else: Exit Sub
 End If
 
 For Each sht In Sheets '遍历工作表
 '将工作表复制到新工作簿中（相当于新建一个文件，再将当前表复制到其中,但新工作簿中仅仅包括一个工作表）
 sht.Copy
 '将新工作簿保存在刚才选择的路径中，且以工作表名做为工作簿名
 ActiveWorkbook.SaveAs path & sht.Name, xlWorkbookDefault
 '关闭工作簿
 ActiveWorkbook.Close
 Next sht
 End Sub

－End－