恳请完成学生成绩分析表

lianjiexiang

请根据“成绩”表和“参数”表，用VBA把相对应的数据生成到“分析表”中，谢谢。见附件

lianjiexiang

上传附件。。。。。。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set dcs = CreateObject("scripting.dictionary")
   
7.   With Worksheets("参数")
   
8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.     c = .Cells(2, .Columns.Count).End(xlToLeft).Column
   
10.     arr = .Range("a2").Resize(r - 1, c)
    
11.   End With
    
12.   For j = 2 To UBound(arr, 2)
    
13.     Set dcs(arr(1, j)) = CreateObject("scripting.dictionary")
    
14.     For i = 2 To UBound(arr)
    
15.       dcs(arr(1, j))(arr(i, 1)) = arr(i, j)
    
16.     Next
    
17.   Next
    
18.   With Worksheets("成绩")
    
19.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
20.     c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
21.     arr = .Range("a2").Resize(r, c)
    
22.     For i = 2 To UBound(arr)
    
23.       bj = Val(arr(i, 2))
    
24.       If Not d.exists(bj) Then
    
25.         Set d(bj) = CreateObject("scripting.dictionary")
    
26.       End If
    
27.       For j = 5 To UBound(arr, 2)
    
28.         If dcs.exists(arr(1, j)) Then
    
29.           If Len(arr(i, j)) <> 0 Then
    
30.             If Not d(bj).exists(arr(1, j)) Then
    
31.               ReDim brr(1 To 9)
    
32.             Else
    
33.               brr = d(bj)(arr(1, j))
    
34.             End If
    
35.             brr(1) = brr(1) + 1
    
36.             brr(2) = brr(2) + arr(i, j)
    
37.             If IsEmpty(brr(3)) Then
    
38.               brr(3) = arr(i, j)
    
39.             Else
    
40.               If brr(3) < arr(i, j) Then
    
41.                 brr(3) = arr(i, j)
    
42.               End If
    
43.             End If
    
44.             If IsEmpty(brr(4)) Then
    
45.               brr(4) = arr(i, j)
    
46.             Else
    
47.               If brr(4) > arr(i, j) Then
    
48.                 brr(4) = arr(i, j)
    
49.               End If
    
50.             End If
    
51.             If arr(i, j) >= dcs(arr(1, j))("及格") Then
    
52.               brr(5) = brr(5) + 1
    
53.             End If
    
54.             If arr(i, j) >= dcs(arr(1, j))("优良") Then
    
55.               brr(7) = brr(7) + 1
    
56.             End If
    
57.             d(bj)(arr(1, j)) = brr
    
58.           End If
    
59.         End If
    
60.       Next
    
61.     Next
    
62.   End With
    
63.   With Worksheets("分析表")
    
64.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
65.     c = .Cells(4, .Columns.Count).End(xlToLeft).Column
    
66.     arr = .Range("a1").Resize(r, c)
    
67.     For i = 2 To 20 Step 18
    
68.       For k = 1 To 15
    
69.         bj = arr(i + k + 2, 1)
    
70.         If d.exists(bj) Then
    
71.           For j = 2 To 38 Step 9
    
72.             km = Replace(arr(i, j), " ", "")
    
73.             If d(bj).exists(km) Then
    
74.               brr = d(bj)(km)
    
75.               If brr(1) <> 0 Then
    
76.                 brr(2) = Round(brr(2) / brr(1), 2)
    
77.                 If Len(brr(5)) <> 0 Then
    
78.                   brr(6) = Round(brr(5) / brr(1), 2)
    
79.                 End If
    
80.                 If Len(brr(7)) <> 0 Then
    
81.                   brr(8) = Round(brr(7) / brr(1), 2)
    
82.                 End If
    
83.               End If
    
84.               .Cells(i + k + 2, j).Resize(1, UBound(brr)) = brr
    
85.             End If
    
86.           Next
    
87.         End If
    
88.       Next
    
89.     Next
    
90.   End With
    
91.             
    
92.             
    
93. End Sub
    

复制代码

chxw68

楼主把分析表格式设计得太复杂了，代码没有写完，仅供参考吧。

chxw68

楼上代码有问题。

lianjiexiang

chxw68 发表于 2018-7-11 15:40
楼上代码有问题。

老师，又是您帮助我，太感谢您了。我下载下来。

lianjiexiang

     褚老师，试了，非常好用，非常感谢您。     在紧靠各科目的下方有一要求：“年段平均分”能否再帮助一下写出代码

chxw68

详见附件。

lianjiexiang

chxw68 发表于 2018-7-11 18:07
详见附件。

褚老师，新代码试了，非常非常完美。谢谢，谢谢，非常感谢

chxw68

lianjiexiang 发表于 2018-7-11 20:23
褚老师，新代码试了，非常非常完美。谢谢，谢谢，非常感谢

能用就好！