初一年成绩分析

vvw123

zqlpop308 发表于 2019-12-26 15:32
貌似不行，有溢出情况

模拟数据发上来，才能判断哪里需要修改

zqlpop308

完整数据放上去后有溢出情况，或者加的学科体现不出来

vvw123

zqlpop308 发表于 2019-12-26 16:02
完整数据放上去后有溢出情况，或者加的学科体现不出来

1. With Worksheets("录入成绩")
   
2.     r = .Cells(.Rows.Count, 4).End(xlUp).Row
   
3.     arr = .Range("a2:n" & r)

复制代码

这里的范围修改下就行了。
改为

1. With Worksheets("录入成绩")
   
2.     r = .Cells(.Rows.Count, 4).End(xlUp).Row
   
3.     arr = .Range("a2:q" & r)

复制代码

vvw123

vvw123 发表于 2019-12-26 16:08
这里的范围修改下就行了。
改为

年级排名需要改动不少。

zqlpop308

vvw123 发表于 2019-12-26 16:08
这里的范围修改下就行了。
改为

已经可以了，但年级排名不行，不知道是不是我操作问题，谢谢

vvw123

zqlpop308 发表于 2019-12-26 16:02
完整数据放上去后有溢出情况，或者加的学科体现不出来

年级排名代码

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:p" & 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 16
    
17.       If j <= 7 Then
    
18.         arr(i, 17) = arr(i, 17) + arr(i, j)
    
19.       End If
    
20.       arr(i, 19) = arr(i, 19) + arr(i, j)
    
21.     Next
    
22.     d(1)(arr(i, 17)) = d(1)(arr(i, 17)) + 1
    
23.     d(2)(arr(i, 19)) = d(2)(arr(i, 19)) + 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, 18) = d(1)(arr(i, 17))
    
37.     arr(i, 20) = d(2)(arr(i, 19))
    
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 = Split(Worksheets("录入成绩").Range("a1").Value, "成绩")(0) & vbLf & "年段第" & cs(1) & "-" & cs(2) & "名成绩排名表"
    
53.       With .Font
    
54.         .Size = 18
    
55.         .Bold = True
    
56.       End With
    
57.     End With
    
58.     .Rows(1).RowHeight = 50
    
59.     .Range("a4").Resize(m, UBound(brr, 2)) = brr
    
60.     .Range("a4:t" & m + 3).Sort key1:=.Cells(4, cs(3)), order1:=xlAscending, Header:=xlNo
    
61.     .Range("a2:t" & m + 3).Borders.LineStyle = xlContinuous
    
62.   End With
    
63. End Sub

复制代码

vvw123

zqlpop308 发表于 2019-12-26 16:23
已经可以了，但年级排名不行，不知道是不是我操作问题，谢谢

代码在审核，也需要修改

zqlpop308

vvw123 发表于 2019-12-26 16:24
代码在审核，也需要修改

谢谢你，麻烦你了，大神膜拜

vvw123

zqlpop308 发表于 2019-12-26 16:26
谢谢你，麻烦你了，大神膜拜

代码已经通过审核，PS：不是大神，大神是褚老师，这些代码原创是褚老师的，我只是小小的改动。

chxw68

vvw123 发表于 2019-12-26 17:19
代码已经通过审核，PS：不是大神，大神是褚老师，这些代码原创是褚老师的，我只是小小的改动。

会修改代码也是不简单。