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

如果我是真的 · 发表于 2010-1-5 19:25

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

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

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

来生缘 · 发表于 2010-1-5 20:36

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

如果我是真的 · 发表于 2010-1-5 20:56

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

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

zhaogang1960 · 发表于 2010-1-5 23:32

请测试：
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 · 发表于 2010-1-6 13:30

非常感谢你在
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 · 发表于 2012-11-2 11:44

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

LMY123 · 发表于 2018-1-28 17:09

多表同时拆分

		自动登录	找回密码
密码			免费注册

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

评分

点评