[已解决]总表拆分问题，请人帮忙。谢谢。

如果我是真的

详见附件。
运行代码后想实现效果，产生一个“拆分表”目录及里面的文件，目录里的文件跟附件中“拆分表1”中内容一样。
发现问题：
1、拆分的工作簿中，第四张表“奖罚分”拆不出内容…………
2、拆分到“济南”这个部门时，对象错误。
3、拆分后的工作簿无法保持与总表格式一样。最起码列宽一样。
4、也是最重要的，这才几个部门运行就这么慢。如果部门增加到100个，那是不是计算机会死机？请帮忙优化一下代码！

切盼高手给予帮助，再次表示感谢。

[ 本帖最后由 如果我是真的 于 2010-1-6 16:10 编辑 ]

来生缘

要求是什么？怎么拆？研究别人的代码是件痛苦的事

如果我是真的

原帖由 来生缘 于 2010-1-5 20:36 发表
要求是什么？怎么拆？研究别人的代码是件痛苦的事

对不起，我疏忽了。
更新了附件，附件里有一个“拆分表1”目录，那就是要实现的结果。当然没考虑到列宽的问题。
有劳你了。

zhaogang1960

请测试：
Sub Macro1()
    Dim wb As Workbook, arr, sh As Worksheet
    Dim k, t, i&, j&, d As Object, ds As Object
    Set d = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
    For Each sh In Sheets
        Set ds(sh.Name) = CreateObject("scripting.dictionary")
        arr = sh.UsedRange
        For i = 4 To sh.Range("a65536").End(xlUp).Row
            If Len(arr(i, 1)) Then
                 If Asc(arr(i, 1)) < 0 Then
                    d(arr(i, 1)) = ""
                    ds(sh.Name)(arr(i, 1)) = i
                 End If
            End If
        Next
        ds(sh.Name)("") = i
    Next
    k = d.Keys
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With ThisWorkbook
        For i = 0 To UBound(k)
            Set wb = Workbooks.Add(xlWBATWorksheet)
            For Each sh In .Sheets
                sh.Copy After:=wb.Sheets(wb.Sheets.Count)
                With wb.Sheets(wb.Sheets.Count)
                    t = ds(.Name).Items
                    arr = .UsedRange
                    For j = UBound(t) - 1 To 0 Step -1
                        If arr(t(j), 1) <> k(i) Then .Cells(t(j), 1).Resize(t(j + 1) - t(j)).EntireRow.Delete
                    Next
                End With
            Next
            wb.Sheets(1).Delete
            wb.SaveAs ThisWorkbook.Path & "\拆分表1\" & k(i) & ".xls"
            wb.Close
        Next
    End With
    MsgBox "ok"
End Sub

zhaogang1960

非常感谢你在
http://club.excelhome.net/viewthread.php?tid=522120
的帮助。
不知能否受累帮忙加上代码注释？学习一下？
再次表示感谢。

以上短信收到，注释如下：
Sub Macro1()
    Dim wb As Workbook, arr, sh As Worksheet
    Dim k, t, i&, j&, d As Object, ds As Object
    Set d = CreateObject("scripting.dictionary") '创建字典对象
    Set ds = CreateObject("scripting.dictionary")
    For Each sh In Sheets '逐表
        Set ds(sh.Name) = CreateObject("scripting.dictionary") '创建该表字典对象
        arr = sh.UsedRange '已经使用区域写入数组
        For i = 4 To sh.Range("a65536").End(xlUp).Row '逐行
            If Len(arr(i, 1)) Then '非空
                 If Asc(arr(i, 1)) < 0 Then '汉字
                    d(arr(i, 1)) = "" '部门名称添加到字典键值(不重复部门名称)
                    ds(sh.Name)(arr(i, 1)) = i '部门名称添加到该表字典键值，行号添加到字典条目
                 End If
            End If
        Next
        ds(sh.Name)("") = i '多记录一个行号(最后一个非空单元格下面一行)
    Next
    k = d.Keys '不重复部门名称写入数组
    Application.ScreenUpdating = False '关闭屏幕刷新
    Application.DisplayAlerts = False '关闭警告
    With ThisWorkbook '本工作簿
        For i = 0 To UBound(k) '逐个不重复部门
            Set wb = Workbooks.Add(xlWBATWorksheet) '新建一个只有一个工作表的工作簿
            For Each sh In .Sheets '本工作簿逐表
                sh.Copy After:=wb.Sheets(wb.Sheets.Count) '工作表复制到新建工作簿后面
                With wb.Sheets(wb.Sheets.Count) '新复制工作表
                    t = ds(.Name).Items '新复制工作表字典记录所有部门名称行号写入数组
                    arr = .UsedRange '已经使用区域写入数组
                    For j = UBound(t) - 1 To 0 Step -1 '从下至上逐个部门名称行号
                        If arr(t(j), 1) <> k(i) Then .Cells(t(j), 1).Resize(t(j + 1) - t(j)).EntireRow.Delete '如果该部门名称不等于不重复部门则所在区域整行删除
                    Next
                End With
            Next
            wb.Sheets(1).Delete '删除新建工作簿第一个空工作表
            wb.SaveAs ThisWorkbook.Path & "\拆分表1\" & k(i) & ".xls" '另存为新建工作簿，名称为个不重复部门
            wb.Close '关闭新建工作簿
        Next
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

myworld669

版主zhaogang1960还在吗？我也有同样问题求助，我要拆出来的分表格式固定（不同于总表），能解决吗？

LMY123

多表同时拆分