求助下分数段人数统计问题，谢谢

明天会更好zj

这个用公式还简单一点

lktqj

明天会更好zj 发表于 2022-4-16 11:35
这个用公式还简单一点

谢谢，公式简单但是班级，分数段需要改动的时候，公式就会自己手动改动，这样就没有用VBA方便了

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr(), crr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   mc = Application.InputBox(prompt:="请输入需要排名前N名：", Title:="操作提示", Default:=5, Type:=1)
   
9.   With Worksheets("文科")
   
10.     .AutoFilterMode = False
    
11.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.     c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
13.     arr = .Range("a2").Resize(r - 1, c)
    
14.   End With
    
15.   For j = 5 To UBound(arr, 2)
    
16.     If arr(1, j) <> "年排" And arr(1, j) <> "班排" Then
    
17.       m = 0
    
18.       For i = 2 To UBound(arr)
    
19.         If arr(i, j + 1) <= mc Then
    
20.           m = m + 1
    
21.           ReDim Preserve brr(1 To 3, 1 To m)
    
22.           brr(1, m) = arr(i, j)
    
23.           brr(2, m) = arr(i, 1)
    
24.           brr(3, m) = arr(i, 2)
    
25.         End If
    
26.       Next
    
27.       If m > 0 Then
    
28.         ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
29.         For x = 1 To UBound(brr)
    
30.           For y = 1 To UBound(brr, 2)
    
31.             crr(y, x) = brr(x, y)
    
32.           Next
    
33.         Next
    
34.         d(arr(1, j)) = crr
    
35.       End If
    
36.     End If
    
37.   Next
    
38.   ls = d.Count * 3
    
39.   With Worksheets("文科前10名")
    
40.     .Cells.Clear
    
41.     With .Range("a1")
    
42.       .Value = "文科年级各科前" & mc & "名"
    
43.       .Resize(1, ls).Merge
    
44.       With .Font
    
45.         .Name = "微软雅黑"
    
46.         .Size = 16
    
47.       End With
    
48.     End With
    
49.     n = 1
    
50.     For Each aa In d.keys
    
51.       crr = d(aa)
    
52.       With .Cells(2, n)
    
53.         .Value = aa
    
54.         .Resize(1, 3).Merge
    
55.       End With
    
56.       .Cells(3, n).Resize(1, 3) = Array("成绩", "姓名", "班级")
    
57.       .Cells(4, n).Resize(UBound(crr), UBound(crr, 2)) = crr
    
58.       .Cells(4, n).Resize(UBound(crr), UBound(crr, 2)).Sort key1:=.Cells(4, n), order1:=xlDescending, Header:=xlNo
    
59.       With .Cells(2, n).Resize(2 + UBound(crr), UBound(crr, 2))
    
60.         .Borders.LineStyle = xlContinuous
    
61.         With .Font
    
62.           .Name = "微软雅黑"
    
63.           .Size = 11
    
64.         End With
    
65.       End With
    
66.       n = n + 3
    
67.     Next
    
68.     .Columns(1).Resize(, ls).AutoFit
    
69.     With .UsedRange
    
70.       .HorizontalAlignment = xlCenter
    
71.       .VerticalAlignment = xlCenter
    
72.     End With
    
73.   End With
    
74. End Sub

复制代码

chxw68

重新写的代码。

lktqj

chxw68 发表于 2022-4-16 21:02
重新写的代码。

真的感谢，这么晚还为我们这些差生答疑。老师用的是中式排名吧，等你有空能否改为美式排名呢？谢谢刚运行看了下，统计前5名人数还多了。

chxw68

lktqj 发表于 2022-4-16 22:46
真的感谢，这么晚还为我们这些差生答疑。老师用的是中式排名吧，等你有空能否改为美式排名呢？谢谢刚运行 ...

用的原表中的排名。

熊文来

chxw68 发表于 2022-4-16 21:02
重新写的代码。

厉害了，最近又在无私帮助大家。

chxw68

熊文来 发表于 2022-4-16 22:56
厉害了，最近又在无私帮助大家。

来得少了。

lktqj

chxw68 发表于 2022-4-16 22:55
用的原表中的排名。

谢谢老师，原来问题出在原始数据上面了，你的代码真的是太漂亮了，比我自己改的代码好太多了。

chxw68

lktqj 发表于 2022-4-17 08:33
谢谢老师，原来问题出在原始数据上面了，你的代码真的是太漂亮了，比我自己改的代码好太多了。:lovelines ...

上面的代码用了字典，主要是考虑代码的适应性了。实际上可以不用字典，这样代码要简单一些。