初一年成绩分析

chxw68

修改好了，你看看。

chxw68

原来是你的等级表里把“B”输入成了“B ”，多了一个空格。

chxw68

1. Sub test3()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, zrr(), fsd() As Variant
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   Set d2 = CreateObject("scripting.dictionary")
   
10.   Set d3 = CreateObject("scripting.dictionary")
    
11.   Call main
    
12.   With Worksheets("录入成绩")
    
13.     r = .Cells(.Rows.Count, 4).End(xlUp).Row
    
14.     arr = .Range("a2:n" & r)
    
15.   End With
    
16.   
    
17.   For j = 5 To UBound(arr, 2) - 1
    
18.     If Application.Count(Application.Index(arr, 0, j)) > 0 Then
    
19.       Set d(arr(1, j)) = CreateObject("scripting.dictionary")
    
20.       fsd = dcs(arr(1, j))("分数段")
    
21.       ReDim Preserve fsd(1 To UBound(fsd) + 1)
    
22.       fsd(UBound(fsd)) = dcs(arr(1, j))("满分")
    
23.       ls = 2 + UBound(fsd) * 2 + 3
    
24.       For i = 2 To UBound(arr)
    
25.         If Len(arr(i, j)) <> 0 Then
    
26.           If Not d(arr(1, j)).exists(arr(i, 2)) Then
    
27.             ReDim brr(1 To ls)
    
28.             brr(1) = arr(i, 2)
    
29.             brr(2) = arr(1, j)
    
30.           Else
    
31.             brr = d(arr(1, j))(arr(i, 2))
    
32.           End If
    
33.           brr(3) = brr(3) + 1
    
34.           If IsEmpty(brr(4)) Then
    
35.             brr(4) = arr(i, j)
    
36.           Else
    
37.             If brr(4) < arr(i, j) Then
    
38.               brr(4) = arr(i, j)
    
39.             End If
    
40.           End If
    
41.           If IsEmpty(brr(5)) Then
    
42.             brr(5) = arr(i, j)
    
43.           Else
    
44.             If brr(5) > arr(i, j) Then
    
45.               brr(5) = arr(i, j)
    
46.             End If
    
47.           End If
    
48.           n = Application.Match(arr(i, j), fsd)
    
49.           If Not IsError(n) Then
    
50.             n = UBound(fsd) - n + 6
    
51.             brr(n) = brr(n) + 1
    
52.           End If
    
53.         End If
    
54.         d(arr(1, j))(arr(i, 2)) = brr
    
55.       Next
    
56.     End If
    
57.   Next
    
58.   m = 1
    
59.   With Worksheets("分数段A")
    
60.     .Cells.Clear
    
61.     For Each aa In d.keys
    
62.       .Cells(m, 1).Resize(1, 5) = Array("年级", "科目", "实考" & vbLf & "人数", "最高" & vbLf & "分", "最低" & vbLf & "分")
    
63.       n = 6
    
64.       fsd = dcs(aa)("分数段")
    
65.       ReDim Preserve fsd(1 To UBound(fsd) + 1)
    
66.       fsd(UBound(fsd)) = dcs(aa)("满分")
    
67.       ls = 5 + UBound(fsd) * 2
    
68.       For j = UBound(fsd) To 1 Step -1
    
69.         If j = UBound(fsd) Then
    
70.          .Cells(m, n) = ">=" & vbLf & fsd(j)
    
71.         Else
    
72.           .Cells(m, n) = "(" & fsd(j + 1) & "," & vbLf & fsd(j) & "]"
    
73.         End If
    
74.         n = n + 1
    
75.       Next
    
76.       For j = UBound(fsd) To 1 Step -1
    
77.         .Cells(m, n) = fsd(j) & "分" & vbLf & "以上"
    
78.         n = n + 1
    
79.       Next
    
80.       ReDim crr(1 To d(aa).Count, 1 To ls)
    
81.       ReDim drr(1 To ls)
    
82.       x = 0
    
83.       For Each bb In d(aa).keys
    
84.         brr = d(aa)(bb)
    
85.         x = x + 1
    
86.         For j = 1 To UBound(brr)
    
87.           crr(x, j) = brr(j)
    
88.         Next
    
89.         For j = 1 To UBound(fsd)
    
90.           If j = 1 Then
    
91.             crr(x, 5 + UBound(fsd) + j) = crr(x, j + 5)
    
92.           Else
    
93.             crr(x, 5 + UBound(fsd) + j) = crr(x, 5 + UBound(fsd) + j - 1) + crr(x, j + 5)
    
94.           End If
    
95.         Next
    
96.       Next
    
97.       drr(1) = "小计"
    
98.       drr(2) = aa
    
99.       drr(3) = Application.Sum(Application.Index(crr, 0, 3))
    
100.       drr(4) = Application.Max(Application.Index(crr, 0, 4))
     
101.       drr(5) = Application.Min(Application.Index(crr, 0, 5))
     
102.       For j = 6 To UBound(crr, 2)
     
103.         drr(j) = Application.Sum(Application.Index(crr, 0, j))
     
104.       Next
     
105.       
     
106.       .Cells(m + 1, 1).Resize(1, UBound(drr)) = drr
     
107.       .Cells(m + 2, 1).Resize(UBound(crr), UBound(crr, 2)) = crr
     
108.       .Rows(m).RowHeight = 28
     
109.       .Rows(m + 1).Resize(UBound(crr) + 2).RowHeight = 15
     
110.       With .Cells(m, 1).Resize(UBound(crr) + 2, UBound(crr, 2))
     
111.         .Borders.LineStyle = xlContinuous
     
112.         .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
     
113.         With .Font
     
114.           .Size = 10
     
115.         End With
     
116.       End With
     
117.       With .Cells(m, 5 + UBound(fsd)).Resize(UBound(crr) + 2, 1).Borders(xlEdgeRight)
     
118.           .LineStyle = xlContinuous
     
119.           .Weight = xlMedium
     
120.       End With
     
121.       m = m + UBound(crr) + 3
     
122.     Next
     
123.     .Columns.AutoFit
     
124.     With .UsedRange
     
125.       .HorizontalAlignment = xlCenter
     
126.       .VerticalAlignment = xlCenter
     
127.     End With
     
128.   End With
     
129. End Sub
     
130. 
     

复制代码

chxw68

详见附件。

vvw123

chxw68 发表于 2019-1-2 17:06
详见附件。

教科书式的经典案例，完全可以收录知识树。

chxw68

1. Sub test4(ByVal cs As Variant)
   
2.   Dim r%, i%
   
3.   Dim arr, brr, zrr()
   
4.   Dim d(1 To 2) As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   For i = 1 To 2
   
8.     Set d(i) = CreateObject("scripting.dictionary")
   
9.   Next
   
10.   With Worksheets("录入成绩")
    
11.     r = .Cells(.Rows.Count, 4).End(xlUp).Row
    
12.     arr = .Range("a3:m" & r)
    
13.   End With
    
14.   ReDim Preserve arr(1 To UBound(arr), 1 To UBound(arr, 2) + 4)
    
15.   For i = 1 To UBound(arr)
    
16.     For j = 5 To 13
    
17.       If j <= 7 Then
    
18.         arr(i, 14) = arr(i, 14) + arr(i, j)
    
19.       End If
    
20.       arr(i, 16) = arr(i, 16) + arr(i, j)
    
21.     Next
    
22.     d(1)(arr(i, 14)) = d(1)(arr(i, 14)) + 1
    
23.     d(2)(arr(i, 16)) = d(2)(arr(i, 16)) + 1
    
24.   Next
    
25.   For i = 1 To 2
    
26.     nn = 1
    
27.     kk = d(i).keys
    
28.     For k = 0 To UBound(kk)
    
29.       mm = Application.Large(kk, k + 1)
    
30.       ss = d(i)(mm)
    
31.       d(i)(mm) = nn
    
32.       nn = nn + ss
    
33.     Next
    
34.   Next
    
35.   For i = 1 To UBound(arr)
    
36.     arr(i, 15) = d(1)(arr(i, 14))
    
37.     arr(i, 17) = d(2)(arr(i, 16))
    
38.   Next
    
39.   ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
40.   m = 0
    
41.   For i = 1 To UBound(arr)
    
42.     If arr(i, cs(3)) >= cs(1) And arr(i, cs(3)) <= cs(2) Then
    
43.       m = m + 1
    
44.       For j = 1 To UBound(arr, 2)
    
45.         brr(m, j) = arr(i, j)
    
46.       Next
    
47.     End If
    
48.   Next
    
49.   With Worksheets("年级排名")
    
50.     .UsedRange.Offset(3, 0).Clear
    
51.     With .Range("a1")
    
52.       .Value = "年段第" & cs(1) & "-" & cs(2) & "名成绩排名表"
    
53.       With .Font
    
54.         .Size = 18
    
55.         .Bold = True
    
56.       End With
    
57.     End With
    
58.     .Range("a4").Resize(m, UBound(brr, 2)) = brr
    
59.     .Range("a4:q" & m + 3).Sort key1:=.Cells(4, cs(3)), order1:=xlAscending, Header:=xlNo
    
60.     .Range("a2:q" & m + 3).Borders.LineStyle = xlContinuous
    
61.   End With
    
62. End Sub
    
63. 
    

复制代码

chxw68

所有代码都写完了。

chxw68

所有代码都写完了。

gtbb2002

chxw68 发表于 2019-1-2 23:08
所有代码都写完了。

褚老师，您好，再一次感谢您的无偿帮助，感恩。我代表学校感谢您。

gtbb2002

chxw68 发表于 2019-1-2 23:07
所有代码都写完了。

褚老师，您好   "如何在 "年段第" & cs(1) & "-" & cs(2) & "名成绩排名表"这句话前添加录入成绩A1单元格的内容呢，还有这句话 .Value = "各科质量分析"前也添加录入成绩A1单元格的内容呢南洪市第六中学2017-2018学年度期中考成绩各科质量分析