完善工作表拆分

zhaogang1960

zhangguochang 发表于 2014-2-24 23:34
你看看这个就明白了

请测试：

1. Sub 字典加数组()
   
2.     Dim arr, brr(), sh As Worksheet, d As Object, k, t, a, i&, j&, m&, l&, s$, rng As Range
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = [a1].CurrentRegion
   
7.     For i = 6 To UBound(arr) - 1
   
8.         s = arr(i, 3)
   
9.         d(s) = d(s) & "," & i
   
10.     Next
    
11.     k = d.Keys
    
12.     t = d.Items
    
13.     For Each sh In Sheets
    
14.         If sh.Name <> "总表" Then sh.Delete
    
15.     Next
    
16.     Set sh = Sheets("总表")
    
17.     For i = 0 To d.Count - 1
    
18.         a = Split(t(i), ",")
    
19.         ReDim brr(1 To UBound(a), 1 To 11)
    
20.         For j = 1 To UBound(a)
    
21.             For l = 1 To 10
    
22.                 r = a(j)
    
23.                 brr(j, l) = arr(r, l)
    
24.             Next
    
25.             brr(j, 11) = arr(r, 15)
    
26.         Next
    
27.         sh.Copy After:=Sheets(Sheets.Count)
    
28.         With ActiveSheet
    
29.             For Each shp In .Shapes
    
30.                 shp.Delete
    
31.             Next
    
32.             .Name = k(i)
    
33.             .Columns("L:O").Delete Shift:=xlToLeft
    
34.             .[K4] = k(i)
    
35.             .[K5] = sh.Rows(4).Find(k(i), , , 1).Offset(1).Value
    
36.             .Cells(6, 1).Resize(j - 1, 11) = brr
    
37.             .UsedRange.Offset(j + 4).Clear
    
38.         End With
    
39.     Next
    
40.     Application.ScreenUpdating = True
    
41. End Sub
    

复制代码

zhaogang1960

请看附件
工作表拆分1.rar (25.22 KB, 下载次数: 73)

2014-2-25 00:00 上传

点击文件名下载附件

liu-aguang

1. Sub test()
   
2.     Dim rng1, rng, d, k, c, firstAddress$
   
3.     Set rng = Sheets(1).Range("a1:k5")
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With Sheets("总表")
   
6.         For i = 11 To 14
   
7.             d(.Cells(4, i).Value) = .Cells(5, i)
   
8.         Next
   
9.         For Each k In d.keys
   
10.             Set c = .Columns(3).Find(k)
    
11.             If Not c Is Nothing Then
    
12.                 firstAddress = c.Address
    
13.                 Set rng1 = Union(.Cells(c.Row, 1).Resize(1, 10), c.Offset(0, 12))
    
14.                 Do
    
15.                     Set c = .Columns(3).FindNext(c)
    
16.                     If Not c Is Nothing Then _
    
17.                     Set rng1 = Union(rng1, .Cells(c.Row, 1).Resize(1, 10), c.Offset(0, 12))
    
18.                 Loop While Not c Is Nothing And c.Address <> firstAddress
    
19.             End If
    
20.             With Worksheets.Add(after:=ActiveSheet)
    
21.                 rng.Copy .[a1]
    
22.                 rng1.Copy .[a6]
    
23.                 .Name = k: .[k4] = k: .[k5] = d(k)
    
24.                 .Shapes(1).Delete: .Shapes(1).Delete
    
25.             End With
    
26.         Next
    
27.     End With
    
28. End Sub
    

复制代码

jbjbzjb

至目前为止，各楼层所写代码均形似而神不似，且存在明显不足，都在无用功：
1.均为硬编码，存在硬伤(若总表结构稍有变化，代码立成废码，譬如删除第2行或者不存在最后的合计行)；
2.有的通过复制“汇总”表来生成分表，未考虑分表数量很多的情况(分表数量多时，代码必将出错)；
3.有的未考虑“期初余额”是否存在的情况；
4.有的考虑了“期初余额”，但始终不明了“期初余额”与发生额的关系(欠缺会计知识)；
5.生成的分表，其“余额”栏未填充公式；
6.其他不足。

评：让楼主检了个便宜。

zhangguochang

jbjbzjb 发表于 2014-2-25 10:17
至目前为止，各楼层所写代码均形似而神不似，且存在明显不足，都在无用功：
1.均为硬编码，存在硬伤(若总表 ...

您做的太好了，完全懂我的意思，不过有一点不足的地方，就是分完后 在分表中多了一个“GG公司"的表，如果没有”GG公司“那就更好了

jbjbzjb

zhangguochang 发表于 2014-2-25 11:30
您做的太好了，完全懂我的意思，不过有一点不足的地方，就是分完后 在分表中多了一个“GG公司"的表，如果 ...

您当局者迷!
评：
1.关于“GG公司”是特意修改了C列的数据有效性追加的一个公司，目的是一为了调试需要，二为了让您明确代码有这项提示的功能，防止某个公司漏结转了上期期末余额；
2.关于代码的友善提示，代码中还有别处；
3.您铁定没注意到“B公司”的期初余额也被我改了，故意设为了空值，为什么该“B公司”期初同样没余额但却未提示呢？!自行考虑；
4.其他不多说。

zhangguochang

哦，晓得了，太感谢您了，给我解决了大问题

lzqmsy

留个记号,学习学习

feng16888

我是做财务的，有必要学习一下