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

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 = NothingEnd 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－