关于区间统计人数

戎马书生222

有一个成绩文件，想统计一个县名次区间对应的人数。判断是用总分字段判断的。具体效果见附件。

求论坛大侠给个思路学习一下。

ykcbf1100

附件供参考。。。
加了一档，不然，结果会出错。

ykcbf1100

区间统计。。。

1. Sub ykcbf() '//2025.1.28
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("Sheet1")
   
5.         zrr = .[r1].CurrentRegion
   
6.         arr = .[a1].CurrentRegion
   
7.     End With
   
8.     On Error Resume Next
   
9.     For i = 2 To UBound(arr)
   
10.         For x = 2 To UBound(zrr)
    
11.             If x = UBound(zrr) Then r1 = zrr(UBound(zrr), 2): r2 = 1000
    
12.             r1 = zrr(x, 2): r2 = zrr(x + 1, 2)
    
13.             If arr(i, 15) >= r1 And arr(i, 15) < r2 Then c = x: Exit For
    
14.         Next
    
15.         s = arr(i, 1) & "|" & c
    
16.         d(s) = d(s) + 1
    
17.     Next
    
18.     With Sheets("结果")
    
19.         .UsedRange.Offset(1, 1).ClearContents
    
20.         arr = .UsedRange
    
21.         For i = 2 To UBound(arr)
    
22.             For j = 2 To UBound(arr, 2)
    
23.                 If arr(i, 1) <> Empty Then
    
24.                     s = arr(i, 1) & "|" & j
    
25.                     If d.exists(s) Then arr(i, j) = d(s)
    
26.                 End If
    
27.             Next
    
28.         Next
    
29.         .UsedRange = arr
    
30.     End With
    
31.     Set d = Nothing
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK！"
    
34. End Sub
    

复制代码

飞天篮球猪

集算器解法...适用大数据...仅供参考

戎马书生222

感谢，感谢

ykcbf1100

戎马书生222 发表于 2025-1-28 11:08
感谢，感谢

附件已更新，原结果有点问题，代码倒是不用改。

ykcbf1100

换一个写法，全表自动生成

ykcbf1100

全表自动生成

1. Sub ykcbf2()   '//2025.1.28
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("结果")
   
6.     ReDim brr(1 To 10000, 1 To 100)
   
7.     bt = 1  '//标题行
   
8.     m = bt: n = 1
   
9.     On Error Resume Next
   
10.     With Sheets("Sheet1")
    
11.         zrr = .[r1].CurrentRegion
    
12.         arr = .[a1].CurrentRegion
    
13.     End With
    
14.     brr(1, 1) = arr(1, 1)
    
15.     For i = 2 To UBound(zrr)
    
16.         n = n + 1
    
17.         brr(1, n) = zrr(i, 1)
    
18.     Next
    
19.     For i = 2 To UBound(arr)
    
20.         For x = 2 To UBound(zrr)
    
21.             If x = UBound(zrr) Then r1 = zrr(UBound(zrr), 2): r2 = 1000
    
22.             r1 = zrr(x, 2): r2 = zrr(x + 1, 2)
    
23.             If arr(i, 15) >= r1 And arr(i, 15) < r2 Then c = x: Exit For
    
24.         Next
    
25.         s = arr(i, 1)
    
26.         If Not d.exists(s) Then
    
27.             m = m + 1
    
28.             d(s) = m
    
29.             brr(m, 1) = arr(i, 1)
    
30.         End If
    
31.         r = d(arr(i, 1))
    
32.         brr(r, c) = brr(r, c) + 1
    
33.     Next
    
34.     With sh
    
35.         .UsedRange.Clear
    
36.         .Cells.Interior.ColorIndex = 0
    
37.         .[a1].Resize(bt, n).Interior.Color = 49407
    
38.         .[a2].Resize(m - bt, 1).Interior.Color = 5296274
    
39.         With .[a1].Resize(m, n)
    
40.             .Value = brr
    
41.             .Borders.LineStyle = 1
    
42.             .HorizontalAlignment = xlCenter
    
43.             .VerticalAlignment = xlCenter
    
44.             With .Font
    
45.                 .Name = "微软雅黑"
    
46.                 .Size = 11
    
47.             End With
    
48.         End With
    
49.     End With
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "OK！"
    
52. End Sub
    

复制代码

quqiyuan

参与一下，仅供参考
结果工资表的数据全部自动生成

quqiyuan

代码如下。。。

Sub test()
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("sheet1")
    Set sh = wb.Sheets("结果")
    arr = sht.[a1].CurrentRegion
    r = sht.[r1].End(4).Row
    brr = sht.[r2].Resize(r - 1, 2)
    fenshu = Application.Index(brr, , 2)
    n = 0
    ReDim crr(1 To 10000, 1 To r)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        s = arr(i, 1)
        x = arr(i, 15)
        If Not d.exists(s) Then
            n = n + 1
            d(s) = n
        End If
        m = d(s)
        y = Application.Match(x, fenshu)
        crr(m, 1) = s
        crr(m, y + 1) = 1 + crr(m, y + 1)
    Next
    With sh
        .UsedRange.ClearContents
        .[a1] = "班级": [b1].Resize(, r - 1) = Application.Transpose(Application.Index(brr, , 1))
        .[a2].Resize(n, r) = crr
    End With
    Beep
    Set d = Nothing
End Sub