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

rosedowson

需求：将《总表》中不同的“单号”，拆解并新建到不同的SHEET里面去，并按模版格式
1.把不同的“单号”新建成多个SHEET,SHEET名与“单号”一致
2.新SHEET的格式与“模版”一致
3.总表的G:Q列=分表的B9:L18（最多10行）
4.总表的S:T列=分表的B22:C31（最多10行）
5.总表的单号=分表的J1
6.总表的项目名称=分表的C6
  总表的项目代码=分表的C7
  总表的任务类型=分表的C5

总表行数最多65535，“单号”不限量最多500个
大神万分感谢
详见附件，大神请抽空指导一下

不知道为什么

工作表拆分，论坛代码巨多，自己可以尝试学习解决啊

rosedowson

不知道为什么 发表于 2018-9-6 20:52
工作表拆分，论坛代码巨多，自己可以尝试学习解决啊

T_T 找不到资料

不知道为什么

rosedowson 发表于 2018-9-6 20:58
T_T 找不到资料

论坛搜索 工作表拆分  很多的

rosedowson

可以帮忙解决下么

abc123281

可以实现  但大家都嫌麻烦

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

复制代码

chxw68

楼主表述得非常清楚，刚好练练字典。

不知道为什么

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

跟着褚老师学习，我用了3个字典，呵呵。

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

不知道为什么

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

参考