拆分总成绩表中的数据到各班各学科

gfs57

拆分总成绩表中的数据到各班各学科

          如何将 <总成绩表> 中的成绩，按以班级、以学科，并按表格中的顺序，一一对应到位。（其中语文、数学两表各三栏，每栏25行；英语表为两栏，每栏40行）。 谢谢 ！

beta402

透视表拆分应该可以满足你的要求。

gfs57

beta402 发表于 2018-7-11 13:35
透视表拆分应该可以满足你的要求。

谢谢你的回复 ！

gfs57

gfs57 发表于 2018-7-11 14:50
谢谢你的回复 ！

　　我发的附件只是部分数据，实际上学生数有几千人，班级上百个。所以希望能用 VBA 来完成。谢谢

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("总成绩表")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a1:e" & r)
   
9.   End With
   
10.   For i = 2 To UBound(arr)
    
11.     If Not d.exists(arr(i, 2)) Then
    
12.       Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
13.     End If
    
14.     For j = 3 To 5
    
15.       If Not d(arr(i, 2)).exists(arr(1, j)) Then
    
16.         m = 1
    
17.         ReDim brr(1 To 3, 1 To m)
    
18.       Else
    
19.         brr = d(arr(i, 2))(arr(1, j))
    
20.         m = UBound(brr, 2) + 1
    
21.         ReDim Preserve brr(1 To 3, 1 To m)
    
22.       End If
    
23.       brr(1, m) = m
    
24.       brr(2, m) = arr(i, 1)
    
25.       brr(3, m) = arr(i, j)
    
26.       d(arr(i, 2))(arr(1, j)) = brr
    
27.     Next
    
28.   Next
    
29.   For Each aa In d.keys
    
30.     For Each bb In d(aa).keys
    
31.       arr = d(aa)(bb)
    
32.       ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr))
    
33.       For i = 1 To UBound(arr)
    
34.         For j = 1 To UBound(arr, 2)
    
35.           brr(j, i) = arr(i, j)
    
36.         Next
    
37.       Next
    
38.       On Error Resume Next
    
39.       Set ws = Worksheets(aa & "班" & bb)
    
40.       If Err Then
    
41.         Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
42.         ws.Name = aa & "班" & bb
    
43.       End If
    
44.       On Error GoTo 0
    
45.       With Worksheets(aa & "班" & bb)
    
46.         .Cells.Clear
    
47.         With .Range("a1")
    
48.           .Value = "成绩表"
    
49.           .Resize(1, IIf(bb <> "英语", 9, 6)).Merge
    
50.           With .Font
    
51.             .Size = 18
    
52.             .Name = "黑体"
    
53.           End With
    
54.         End With
    
55.         .Range("a2") = "学校"
    
56.         .Range("b2") = "胜利小学"
    
57.         If bb <> "英语" Then
    
58.           .Range("e2") = bb & "科"
    
59.           .Range("h2") = aa & "班"
    
60.         Else
    
61.           .Range("d2") = bb & "科"
    
62.           .Range("f2") = aa & "班"
    
63.         End If
    
64.         For j = 1 To IIf(bb <> "英语", 3, 2)
    
65.           .Cells(3, j * 3 - 2).Resize(1, 3) = Array("座号", "姓名", bb)
    
66.         Next
    
67.         .Range("a4").Resize(UBound(brr), UBound(brr, 2)) = brr
    
68.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
69.         n = 4
    
70.         For i = IIf(bb <> "英语", 29, 44) To r Step IIf(bb <> "英语", 25, 40)
    
71.           .Cells(i, 1).Resize(IIf(bb <> "英语", 25, 40), 3).Cut Destination:=.Cells(4, n)
    
72.           n = n + 3
    
73.         Next
    
74.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
75.         c = .Cells(3, .Columns.Count).End(xlToLeft).Column
    
76.         With .Range("a3").Resize(r - 2, c)
    
77.           .Borders.LineStyle = xlContinuous
    
78.           .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
    
79.         End With
    
80.         For j = 4 To c Step 3
    
81.           With .Cells(3, j).Resize(r - 2, 1).Borders(xlEdgeLeft)
    
82.             .LineStyle = xlContinuous
    
83.             .Weight = xlMedium
    
84.           End With
    
85.         Next
    
86.         With .UsedRange
    
87.          .HorizontalAlignment = xlCenter
    
88.          .VerticalAlignment = xlCenter
    
89.         End With
    
90.       End With
    
91.     Next
    
92.   Next
    
93. End Sub
    

复制代码

chxw68

详见附件。

gfs57

chxw68 发表于 2018-7-11 15:02
详见附件。

下午好 ！

　　衷心感谢你的回复！首先被你上百行的代码吓到了，短短时间写了这么多，还调试过了，佩服佩服！完全达到我想要的效果，就因为单位这台电脑运行不了代码，我得回家后再动手试试。

gfs57

gfs57 发表于 2018-7-11 16:02
下午好 ！

　　衷心感谢你的回复！首先被你上百行的代码吓到了，短短时间写了这么多，还调试过了，佩 ...

　　刚才又细看了一下，原表中已有的东西是不需要我们填写的。我们只要填写学生姓名及各科目成绩即可。

gfs57

gfs57 发表于 2018-7-11 16:05
　　刚才又细看了一下，原表中已有的东西是不需要我们填写的。我们只要填写学生姓名及各科目成绩即可。

　　哦对啦：语文科，只需填写：学生姓名 + 语文成绩；
　　　　　　数学科，只需填写：　　　　　 数学成绩；
　　　　　　英语科，只需填写：　　　　　 英语成绩。
　　这样的话，代码好修改吗？再次感谢 ！

chxw68

gfs57 发表于 2018-7-11 16:12
　　哦对啦：语文科，只需填写：学生姓名 + 语文成绩；
　　　　　　数学科，只需填写：　　　　　 数学 ...

不要座号了？修改起来挺麻烦的。