另类拆分汇总表：能否以一种模板来进行拆分汇总表？汇总表与模板格式完全不一样。

9.17

我的汇总表的格式和分表的格式完全不一样能进行拆分吗？以分表模板的格式对汇总表进行拆分。。
因为实在太多了，一点点输入的话工作量很大~~~
我先上个图，图可能有点乱，大家帮帮忙耐心的看一下，谢谢~~


已模板拆分总表.rar (207.22 KB, 下载次数: 28)

2013-3-7 10:42 上传

点击文件名下载附件

9.17

是不可以实现么？还是我描述的不好？  救命呐~~~

mineshine

9.17 发表于 2013-3-7 15:10
是不可以实现么？还是我描述的不好？  救命呐~~~

仅供参考
代码放模块

1. 
   
2. Sub 拆分为工作表()  '按条件拆分成工作表
   
3.     Dim arr,  d As Object, k, t, sh As Worksheet, i&, S As Worksheet,r
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     For Each sh In Sheets
   
7.         If sh.Name <> "钢筋笼汇总表" And sh.Name <> "分表模板" Then sh.Delete '刪除 当前表以外的工作表
   
8.     Next sh
   
9.     Set S = Sheets("钢筋笼汇总表")
   
10.     arr = S.Range("A7:A" & S.Range("A65536").End(xlUp).Row) '在此修改需要作为拆分依据的列(页数)
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     For i = 1 To UBound(arr)
    
13.         If Not d.Exists(arr(i, 1)) Then
    
14.             '合并单元格 钢筋笼直径(mm)、纵筋间距(mm)、纵筋长度(mm)、箍筋间距(mm)、加强箍筋间距(mm)
    
15.             Set d(arr(i, 1)) = Union(S.Cells(i + 6, 4).Resize(, 2), S.Cells(i + 6, 8), S.Cells(i + 6, 6).Resize(, 2))
    
16.         Else
    
17.             Set d(arr(i, 1)) = Union(d(arr(i, 1)), Union(S.Cells(i + 6, 4).Resize(, 2), S.Cells(i + 6, 8), S.Cells(i + 6, 6).Resize(, 2)))
    
18.         End If
    
19.     Next i
    
20.     k = d.keys  'key值
    
21.     t = d.items '项目
    
22.     For i = 0 To d.Count - 1
    
23.         Set sh = Sheets.Add(after:=Sheets(Sheets.Count))    '新增工作表在所有工作表之后
    
24.         With sh
    
25.             .Name = "页数-" & k(i)    '工作表名
    
26.             Sheets("分表模板").Cells.Copy .[A1] '复制分表模板
    
27.             .[V3] = Left(Format(k(i), "00"), 1)   '页数第一码
    
28.             .[X3] = Mid(Format(k(i), "00"), 2)   '页数第二码
    
29.             .[F5] = S.[B1]  '单位(子单位)工程名称
    
30.             .[F6] = S.[B4]  '分部工程名称
    
31.             .[E7] = S.[B2]  '施工单位
    
32.             .[U7] = S.[B3]  '项目经理
    
33.             r = d(k(i)).Count \ 5 '字典key值(页数个数)除以5(取5个栏位),伝回整数
    
34.             .[J14].Resize(5, r) = WorksheetFunction.Transpose(t(i)) '数组竖向排列
    
35.         End With
    
36.     Next i
    
37.     Set d = Nothing
    
38.     Application.DisplayAlerts = True
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "完成"
    
41. End Sub
    

复制代码

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Sht As Worksheet, j&, aa, c%, zh$, y&
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet4.Activate
   
6. gcmc = [b1].Value: sgdw = [b2].Value: xmjl = [b3].Value: fbmc = [b4].Value
   
7. Myr = [a65536].End(xlUp).Row
   
8. Arr = Range("a7:j" & Myr)
   
9. For i = 1 To UBound(Arr)
   
10.     d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","
    
11. Next
    
12. k = d.keys
    
13. t = d.items
    
14. For i = 0 To UBound(k)
    
15.     Sheets("分表模板").Copy after:=Sheets(Sheets.Count)
    
16.     Set Sht = ActiveSheet
    
17.     Sht.Name = "第" & k(i) & "页"
    
18.     t(i) = Left(t(i), Len(t(i)) - 1)
    
19.     With Sht
    
20.         .[f5] = gcmc
    
21.         .[e7] = sgdw
    
22.         .[f6] = fbmc
    
23.         .[u7] = xmjl: c = 9: zh = ""
    
24.         If k(i) < 10 Then
    
25.             .[x3] = k(i)
    
26.         Else
    
27.             .[v3] = Left(k(i), 1)
    
28.             .[x3] = Right(k(i), 1)
    
29.         End If
    
30.         If InStr(t(i), ",") Then
    
31.             aa = Split(t(i), ",")
    
32.             For j = 0 To UBound(aa)
    
33.                 c = c + 1: zh = zh & Arr(aa(j), 2) & "#、"
    
34.                 For y = 4 To 8
    
35.                     .Cells(10 + y, c) = Arr(aa(j), y)
    
36.                 Next
    
37.             Next
    
38.             .[u22] = Arr(aa(0), 3)
    
39.             .[u25] = Arr(aa(0), 3)
    
40.         Else
    
41.             c = c + 1: zh = Arr(t(i), 2) & "#"
    
42.             For y = 4 To 8
    
43.                 .Cells(10 + y, c) = Arr(t(i), y)
    
44.             Next
    
45.             .[u22] = Arr(t(i), 3)
    
46.             .[u25] = Arr(t(i), 3)
    
47.         End If
    
48.         .[q6] = zh
    
49.     End With
    
50. Next
    
51. MsgBox "OK"
    
52. End Sub
    

复制代码

蓝桥玄霜

请见附件。

9.17

mineshine 发表于 2013-3-7 16:51
仅供参考
代码放模块

谢谢。基本可以实现，但是桩号没有录入哦

9.17

蓝桥玄霜 发表于 2013-3-7 17:08
请见附件。

太感激斑竹，基本满足要求了，但是桩号那里最后一个的时候能自动去掉顿号、吗？

9.17

蓝桥玄霜 发表于 2013-3-7 17:08
请见附件。

想再请教蓝斑竹，如果我模板里面的数据格子是隔开的时候该怎么办？我根据你给我的更改了一下，就是中间段不知道怎么更改，可以再帮我看看吗？
混凝土拆表.rar (206.26 KB, 下载次数: 16)

2013-3-7 19:20 上传

点击文件名下载附件

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, Sht As Worksheet, j&, aa, c%, zh$, y&, h
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Application.ScreenUpdating = False
   
6. Sheet4.Activate
   
7. gcmc = [b1].Value: sgdw = [b2].Value: xmjl = [b3].Value: fbmc = [b4].Value
   
8. h = Array(20, 23, 24, 28, 29)
   
9. Myr = [a65536].End(xlUp).Row
   
10. Arr = Range("a7:j" & Myr)
    
11. For i = 1 To UBound(Arr)
    
12.     d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","
    
13. Next
    
14. k = d.keys
    
15. t = d.items
    
16. For i = 0 To UBound(k)
    
17.     Sheets("分表模板").Copy after:=Sheets(Sheets.Count)
    
18.     Set Sht = ActiveSheet
    
19.     Sht.Name = "第" & k(i) & "页"
    
20.     t(i) = Left(t(i), Len(t(i)) - 1)
    
21.     With Sht
    
22.         .[f5] = gcmc
    
23.         .[e7] = sgdw
    
24.         .[f6] = fbmc
    
25.         .[u7] = xmjl: c = 6: zh = ""
    
26.         If k(i) < 10 Then
    
27.             .[u3] = k(i)
    
28.         Else
    
29.             .[s3] = Left(k(i), 1)
    
30.             .[u3] = Right(k(i), 1)
    
31.         End If
    
32.         If InStr(t(i), ",") Then
    
33.             aa = Split(t(i), ",")
    
34.             For j = 0 To UBound(aa)
    
35.                 c = c + 1: zh = zh & Arr(aa(j), 2) & "#、"
    
36.                 For y = 4 To 8
    
37.                     .Cells(h(y - 4), c) = Arr(aa(j), y)
    
38.                 Next
    
39.             Next
    
40.             .[r32] = Arr(aa(0), 3)
    
41.             .[r35] = Arr(aa(0), 3)
    
42.         Else
    
43.             c = c + 1: zh = Arr(t(i), 2) & "#"
    
44.             For y = 4 To 8
    
45.                 .Cells(h(y - 4), c) = Arr(t(i), y)
    
46.             Next
    
47.             .[r32] = Arr(t(i), 3)
    
48.             .[r35] = Arr(t(i), 3)
    
49.         End If
    
50.         .[n6] = IIf(Right(zh, 1) = "、", Left(zh, Len(zh) - 1), zh)
    
51.     End With
    
52. Next
    
53. Application.ScreenUpdating = True
    
54. MsgBox "OK"
    
55. End Sub
    

复制代码

蓝桥玄霜

请见附件。