大神们，请问如何将单个工作总表某列不同的值拆分成多个其他的工作表？万分感谢

不知道为什么

rosedowson 发表于 2018-9-6 21:29
可以帮忙解决下么

参考

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   vs = [{2,7,17,9;3,19,20,22}]
   
8.   Set d = CreateObject("scripting.dictionary")
   
9.   With Worksheets("总表")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("a3:u" & r)
    
12.   End With
    
13.   For i = 1 To UBound(arr)
    
14.     If Not d.exists(arr(i, 2)) Then
    
15.       Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
16.       d(arr(i, 2))(1) = Array(arr(i, 2), arr(i, 5), arr(i, 3), arr(i, 4))
    
17.     End If
    
18.     For k = 1 To UBound(vs)
    
19.       If Not d(arr(i, 2)).exists(vs(k, 1)) Then
    
20.         m = 1
    
21.         ReDim brr(vs(k, 2) To vs(k, 3), 1 To m)
    
22.       Else
    
23.         brr = d(arr(i, 2))(vs(k, 1))
    
24.         m = UBound(brr, 2) + 1
    
25.         ReDim Preserve brr(vs(k, 2) To vs(k, 3), 1 To m)
    
26.       End If
    
27.       For j = vs(k, 2) To vs(k, 3)
    
28.         brr(j, m) = arr(i, j)
    
29.       Next
    
30.       d(arr(i, 2))(vs(k, 1)) = brr
    
31.     Next
    
32.   Next
    
33.   With Worksheets("模板")
    
34.     For Each aa In d.keys
    
35.       .Range("j1,c5:c7,b9:l18,b22:c31") = ""
    
36.       brr = d(aa)(1)
    
37.       .Range("j1") = brr(0)
    
38.       .Range("c5") = brr(1)
    
39.       .Range("c6") = brr(2)
    
40.       .Range("c7") = brr(3)
    
41.       For k = 1 To 2
    
42.         arr = d(aa)(vs(k, 1))
    
43.         ReDim brr(1 To UBound(arr, 2), LBound(arr) To UBound(arr))
    
44.         For i = LBound(arr) To UBound(arr)
    
45.           For j = 1 To UBound(arr, 2)
    
46.             brr(j, i) = arr(i, j)
    
47.           Next
    
48.         Next
    
49.         .Cells(vs(k, 4), 2).Resize(UBound(brr), UBound(brr, 2) - LBound(brr, 2) + 1) = brr
    
50.       Next
    
51.       On Error Resume Next
    
52.       Worksheets(aa).Delete
    
53.       .Copy after:=Worksheets(Worksheets.Count)
    
54.       ActiveSheet.Name = aa
    
55.     Next
    
56.   End With
    
57. End Sub
    

复制代码

chxw68

精简了一下。

rosedowson

chxw68 发表于 2018-9-6 22:28

感谢大神的帮助我明天好好学习下，感谢感谢感谢

rosedowson

不知道为什么 发表于 2018-9-6 22:24
参考

感谢您的慷慨帮助，我明天好好学习下你们的思路和方法

rosedowson

chxw68 发表于 2018-9-6 22:13
楼主表述得非常清楚，刚好练练字典。

谢谢老师我一定好好学

微笑12345

chxw68 发表于 2018-9-6 22:13
楼主表述得非常清楚，刚好练练字典。

就下来默默的学习

EXCEL爱好者2

这样子的表,似乎拆成子表不杂好用啊,直接按记录行套打出来就完事了

chxw68

不知道为什么 发表于 2018-9-6 22:23
跟着褚老师学习，我用了3个字典，呵呵。

原表，只需要保留 总表 和 模板 2个sheet 就可以，如图

互相学习！字典不再乎用了多少，只要能高效达成目的就行。

chxw68

1. Sub test2()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, zrr()
   
4.   Application.ScreenUpdating = False
   
5.   Application.DisplayAlerts = False
   
6.   With Worksheets("总表")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a3:u" & r)
   
9.     xm = ""
   
10.     For i = 1 To UBound(arr)
    
11.       If arr(i, 2) <> xm Then
    
12.         m = m + 1
    
13.         ReDim Preserve zrr(1 To 2, 1 To m)
    
14.         zrr(1, m) = i
    
15.         zrr(2, m) = i
    
16.         xm = arr(i, 2)
    
17.       Else
    
18.         zrr(2, m) = i
    
19.       End If
    
20.     Next
    
21.   End With
    
22.   With Worksheets("模板")
    
23.     For k = 1 To UBound(zrr, 2)
    
24.       .Range("j1,c5:c7,b9:l18,b22:c31") = ""
    
25.       .Range("j1") = arr(zrr(1, k), 2)
    
26.       .Range("c5") = arr(zrr(1, k), 5)
    
27.       .Range("c6") = arr(zrr(1, k), 3)
    
28.       .Range("c7") = arr(zrr(1, k), 4)
    
29.       ReDim brr(1 To zrr(2, k) - zrr(1, k) + 1, 1 To 11)
    
30.       ReDim crr(1 To zrr(2, k) - zrr(1, k) + 1, 1 To 2)
    
31.       m = 0
    
32.       For i = zrr(1, k) To zrr(2, k)
    
33.         m = m + 1
    
34.         For j = 1 To 11
    
35.           brr(m, j) = arr(i, j + 6)
    
36.         Next
    
37.         For j = 1 To 2
    
38.           crr(m, j) = arr(i, j + 18)
    
39.         Next
    
40.       Next
    
41.       .Range("b9").Resize(UBound(brr), UBound(brr, 2)) = brr
    
42.       .Range("b22").Resize(UBound(crr), UBound(crr, 2)) = crr
    
43.       On Error Resume Next
    
44.       Worksheets(arr(zrr(1, k), 2)).Delete
    
45.       .Copy after:=Worksheets(Worksheets.Count)
    
46.       ActiveSheet.Name = arr(zrr(1, k), 2)
    
47.     Next
    
48.   End With
    
49. End Sub
    
50. 
    

复制代码