完善工作表拆分

zhangguochang

zhaogang1960 发表于 2014-2-24 22:41
请参考：

不是这样的，我的分表和主表在最后一列是不一样的，分表最后一列的余额是要有公式计算的

zhangguochang

您下载我的附件 工作表拆分.zip (20.22 KB, 下载次数: 3)

2014-2-24 23:02 上传

点击文件名下载附件

，把主表项目1---项目4的文字清空后，运行一下看看，就明白了，我的问题是当项目1---项目4加上文字，就无法运行了，还有就是要求：1、各个分表的样式要和主表一致，包括字体、表格的格式等；2、各分表的项目5 项目6的求和本人不会做，请大师帮忙完善

zhaogang1960

zhangguochang 发表于 2014-2-24 22:59
不是这样的，我的分表和主表在最后一列是不一样的，分表最后一列的余额是要有公式计算的

放弃字典法，先排序再复制数据：

1. Sub 字典拆分()
   
2.     Dim sh As Worksheet, arr, brr&(), m&, s$, i&, k, t, lc&
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     With [a1].CurrentRegion
   
6.         .Offset(5).Resize(.Rows.Count - 6).Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlNo
   
7.     End With
   
8.     arr = [a1].CurrentRegion
   
9.     lc = UBound(arr, 2)
   
10.     ReDim brr(1 To UBound(arr))
    
11.     For i = 6 To UBound(arr) - 1
    
12.         If arr(i, 3) <> arr(i - 1, 3) Then
    
13.             m = m + 1
    
14.             brr(m) = i
    
15.         End If
    
16.     Next
    
17.     brr(m + 1) = i
    
18.     For Each sh In Sheets
    
19.         If sh.Name <> "总表" Then sh.Delete
    
20.     Next
    
21.     Set sh = Sheets("总表")
    
22.     For i = 1 To m
    
23.         sh.Copy After:=Sheets(Sheets.Count)
    
24.         With ActiveSheet
    
25.             For Each shp In .Shapes
    
26.                 shp.Delete
    
27.             Next
    
28.             .Name = arr(brr(i), 3)
    
29.             .UsedRange.Offset(5).Clear
    
30.             sh.Cells(brr(i), 1).Resize(brr(i + 1) - brr(i), lc).Copy .Cells(6, 1)
    
31.         End With
    
32.     Next
    
33.     sh.Activate
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    

复制代码

zhaogang1960

请测试附件
工作表拆分.rar (22.38 KB, 下载次数: 39)

2014-2-24 23:14 上传

点击文件名下载附件

zhangguochang

zhaogang1960 发表于 2014-2-24 23:15
请测试附件

您下载我的附件   工作表拆分.zip (20.22 KB, 下载次数: 0) ，把主表项目1---项目4的文字清空后，运行一下看看，就明白了，我的问题是当项目1---项目4加上文字，就无法运行了，还有就是要求：1、各个分表的样式要和主表一致，包括字体、表格的格式等；2、各分表的项目5 项目6的求和本人不会做，请大师帮忙完善

longming3

1. Sub 拆分()
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheets("总表").Range("a6:o" & Range("c65536").End(xlUp).Row)
   
5.     For i = 1 To UBound(arr)
   
6.         d(arr(i, 3)) = ""
   
7.     Next
   
8.     tt = d.keys
   
9.     For i = 0 To d.Count - 1
   
10.         Sheets("总表").Copy after:=Sheets.Item(Sheets.Count) '添加工作表
    
11.         ActiveSheet.Shapes.Range(Array("Button 1", "Button 2")).Delete
    
12.         ActiveSheet.Range("a6:n" & Range("c65536").End(xlUp).Row).ClearContents
    
13.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 1)
    
14.         For j = 1 To UBound(arr)
    
15.             If arr(j, 3) = tt(i) Then
    
16.                 y = y + 1
    
17.                 For k = 1 To UBound(brr, 2)
    
18.                     brr(y, k) = arr(j, k)
    
19.                 Next
    
20.             End If
    
21.         Next
    
22.         ActiveSheet.Range("a6").Resize(y, UBound(brr, 2)) = brr
    
23.         ActiveSheet.Name = tt(i) '命名工作表
    
24.         y = 0
    
25.     Next
    
26.     Application.ScreenUpdating = True
    
27. End Sub

复制代码

longming3

工作表拆分.rar (13.74 KB, 下载次数: 18)

2014-2-24 23:25 上传

点击文件名下载附件

zhaogang1960

zhangguochang 发表于 2014-2-24 23:19
您下载我的附件   工作表拆分.zip (20.22 KB, 下载次数: 0) ，把主表项目1---项目4的文字清空后，运行一 ...

13楼代码是先排序，再复制工作表，保留表头5行，再原封不动复制区域

不知道哪里不符合要求？

zhangguochang

zhaogang1960 发表于 2014-2-24 23:25
13楼代码是先排序，再复制工作表，保留表头5行，再原封不动复制区域

不知道哪里不符合要求？

总表的余额和分表的余额是不一样的

zhangguochang

zhangguochang 发表于 2014-2-24 23:32
总表的余额和分表的余额是不一样的

你看看这个就明白了