工作簿拆分单个工作表，无法处理

mingming3373

想把多个工作表分成单个的工作簿，一个工作簿一一个文件测试了几个代码都是1004错误。

Private Sub 分拆工作表()
       Dim sht As Worksheet
       Dim MyBook As Workbook
       Set MyBook = ActiveWorkbook
       For Each sht In MyBook.Sheets
           sht.Copy
           ActiveWorkbook.SaveAs Filename:=MyBook.Path & "\" & sht.Name, FileFormat:=xlNormal     '将工作簿另存为EXCEL默认格式
           ActiveWorkbook.Close
       Next
       MsgBox "文件已经被分拆完毕!"
   End Sub
Sub 工作薄拆分()
'将工作薄按工作表拆分成多个工作薄
Dim PATH As String
PATH = Application.ActiveWorkbook.PATH
Dim sht As Worksheet
Application.ScreenUpdating = False
For Each sht In Sheets
sht.Copy
ActiveWorkbook.SaveAs PATH & "\" & sht.NAME & ".xls" '(工作表名称为文件名）
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub
Sub UnhideAllSheets()
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Visible = True
Next
End Sub

家长信息模板.rar (173.11 KB, 下载次数: 8)

2017-5-18 15:10 上传

点击文件名下载附件

活在理想的世界

其实你已经完成90%的工作了，剩下的事情就是FOR EACH 循环COPY除sheet1外的每一张工作表，然后另存关闭就可以了。

mingming3373

我还是想用代码解决问题

lsc900707

mingming3373 发表于 2017-5-18 15:52
我还是想用代码解决问题

学会给给予帮助者送花，很多问题都很快解决，不信你试试：
Sub 如何将一个Excel工作表的数据拆分成多个工作表()
    tms = Timer
    Application.ScreenUpdating = False '关闭屏幕更新
    arr = Range("A1").CurrentRegion.Value
    lc = UBound(arr, 2) '求取最后一列的列号
    Set rng = Rows(1) '标题行
    Set Dic = CreateObject("Scripting.Dictionary") '创建字典
    For i = 2 To UBound(arr)
        s = arr(i, 16) '订单号，关键字
        If Not Dic.Exists(s) Then '如果字典没有关键字
            Set Dic(s) = Cells(i, 1).Resize(, lc) '把当前行装入到字典中
        Else '否则(字典中存在关键字)
            Set Dic(s) = Union(Dic(s), Cells(i, 1).Resize(, lc)) '把行连合起来
        End If
    Next
    k = Dic.Keys '字典关键字集合
    t = Dic.Items '字典项目集合
    For i = 0 To Dic.Count - 1 '循环关键字的个数
        With Workbooks.Add(xlWBATWorksheet)
            rng.Copy .Sheets(1).[a1]
            t(i).Copy .Sheets(1).[a2]
            .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i), FileFormat:=xlExcel8
            .Close
        End With
    Next
    Application.ScreenUpdating = True '打开屏幕更新
    MsgBox "拆分完成！耗时" & Timer - tms & "秒"
End Sub

mingming3373

lsc900707 发表于 2017-5-18 16:27
学会给给予帮助者送花，很多问题都很快解决，不信你试试：
Sub 如何将一个Excel工作表的数据拆分成多个工 ...

谢谢问题完美解决

lrh788

lsc900707 发表于 2017-5-18 16:27
学会给给予帮助者送花，很多问题都很快解决，不信你试试：
Sub 如何将一个Excel工作表的数据拆分成多个工 ...

版主，能否先将工作表的数据拆分为本工作簿中的多个工作表，然后在再导出并单独保存为独立的工作簿

lsc900707

lrh788 发表于 2018-6-21 22:07
版主，能否先将工作表的数据拆分为本工作簿中的多个工作表，然后在再导出并单独保存为独立的工作簿

这样的实例很多，自己搜搜看看。

lrh788

我搜了很多个，都没版主写的运行速度快！我工作中常用到这样的问题！还请版主费神写下代码！