变动总表拆分年级学生

458863601

求助各位大师帮忙，留言帮忙写个代码。

lsc900707

多条件按模板拆分，有点繁琐，需要时间处理。

abc123281

用个字典嵌套

458863601

abc123281 发表于 2018-9-20 21:44
用个字典嵌套

怎样弄啊？  可以帮我弄一个吗？

458863601

lsc900707 发表于 2018-9-20 21:38
多条件按模板拆分，有点繁琐，需要时间处理。

可以免费帮忙做一个吗？

zpy2

458863601 发表于 2018-9-20 22:21
可以免费帮忙做一个吗？

如果只是自己查询一下就方便多了。

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("a4:t" & r)
    
11.   End With
    
12.   For i = 1 To UBound(arr)
    
13.     If Not d.exists(arr(i, 20)) Then
    
14.       Set d(arr(i, 20)) = CreateObject("scripting.dictionary")
    
15.     End If
    
16.     If Not d(arr(i, 20)).exists(arr(i, 5)) Then
    
17.       m = 1
    
18.       ReDim brr(1 To 9, 1 To m)
    
19.     Else
    
20.       brr = d(arr(i, 20))(arr(i, 5))
    
21.       m = UBound(brr, 2) + 1
    
22.       ReDim Preserve brr(1 To 9, 1 To m)
    
23.     End If
    
24.     brr(1, m) = m
    
25.     For j = 3 To 7
    
26.       brr(j - 1, m) = arr(i, j)
    
27.     Next
    
28.     If arr(i, 20) = "转入" Then
    
29.       brr(7, m) = arr(i, 20)
    
30.     Else
    
31.       brr(8, m) = arr(i, 20)
    
32.     End If
    
33.     brr(9, m) = arr(i, 10)
    
34.     d(arr(i, 20))(arr(i, 5)) = brr
    
35.   Next
    
36.   For Each aa In d.keys
    
37.     For Each bb In d(aa).keys
    
38.       wjm = aa & bb
    
39.       On Error Resume Next
    
40.       Set ws = Worksheets(wjm)
    
41.       If Err Then
    
42.         Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
43.         ws.Name = wjm
    
44.       End If
    
45.       On Error GoTo 0
    
46.       With Worksheets(wjm)
    
47.         .Range("a6:i20").ClearContents
    
48.         arr = d(aa)(bb)
    
49.         ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr))
    
50.         For i = 1 To UBound(arr)
    
51.           For j = 1 To UBound(arr, 2)
    
52.             brr(j, i) = arr(i, j)
    
53.           Next
    
54.         Next
    
55.         With .Range("a6").Resize(UBound(brr), UBound(brr, 2))
    
56.           .Value = brr
    
57.           With .Font
    
58.             .Size = 9
    
59.             .Name = "宋体"
    
60.           End With
    
61.         End With
    
62.         With .UsedRange
    
63.           .HorizontalAlignment = xlCenter
    
64.           .VerticalAlignment = xlCenter
    
65.         End With
    
66.       End With
    
67.     Next
    
68.   Next
    
69.       
    
70. End Sub
    

复制代码

opiona

见69楼：http://club.excelhome.net/thread-1409141-1-1.html

chxw68

详见附件。