关于区间统计人数

于恒

ykcbf1100 发表于 2025-1-28 12:13
全表自动生成

给草爷拜年了！！！！！！

于恒

ykcbf1100 发表于 2025-1-28 12:13
全表自动生成

想问一下草爷，这个代码用什么编译器写的？怎么能自带行号？？？？

戎马书生222

ykcbf1100 发表于 2025-1-28 12:13
全表自动生成

借用了你以前的代码，也挺好理解的。


Sub 名次区间统计()  '//
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("Scripting.Dictionary")
    brr = Sheets("成绩").Range("s2:s10")
    'b = [{5,10,15,20,25,30,50}]
    ReDim crr(1 To 100, 1 To 100)
    With Sheets("成绩")
        r = .Cells(Rows.Count, 1).End(3).Row
        arr = .[a1].Resize(r, 15)
        For i = 2 To UBound(arr)
            s = arr(i, 1)
            If Not d.exists(s) Then
                m = m + 1
                d(s) = m
                crr(m, 1) = s
            End If
            r = d(arr(i, 1))
            c = 1
            For x = 1 To UBound(brr)
                If arr(i, 15) <= brr(x, 1) Then
                    c = x + c
                    crr(r, c) = crr(r, c) + 1
                    Exit For
                End If
            Next
        Next
        With Sheets("名次区间统计")
        .[a2:j1000].ClearContents
        .[a2].Resize(m, UBound(brr) + 1) = crr
        .[a2].Resize(m, UBound(brr) + 1).Borders.LineStyle = 1
        End With
    End With
    Set d = Nothing
    Application.ScreenUpdating = True
    MsgBox "OK！"
End Sub

ykcbf1100

于恒 发表于 2025-1-28 18:09
想问一下草爷，这个代码用什么编译器写的？怎么能自带行号？？？？

行号是论坛自带的。
新年快乐！

于恒

ykcbf1100 发表于 2025-1-28 20:18
行号是论坛自带的。
新年快乐！

收到！！！！

戎马书生222

戎马书生222 发表于 2025-1-28 18:17
借用了你以前的代码，也挺好理解的。

这个结果不对，有时间我再看看

桑榆非晚123

和AI搞了好久搞出来的

戎马书生222

桑榆非晚123 发表于 2025-1-29 10:10
和AI搞了好久搞出来的

哥们，文件格式得存成.xlsm。没见代码

桑榆非晚123

戎马书生222 发表于 2025-1-29 10:20
哥们，文件格式得存成.xlsm。没见代码

1. Sub ClassScoreSectionStatistics()
   
2.     Dim wsSource As Worksheet, wsResult As Worksheet
   
3.     Dim dataRange As Range
   
4.     Dim rowCount As Long, colClass As Long, colScore As Long
   
5.     Dim scoreSections As Variant
   
6.     Dim classDict As Object
   
7.     Dim i As Long, j As Long, k As Long
   
8.     Dim classKey As Variant
   
9.     Dim rowOutput As Long
   
10.     Dim score As Double
    
11.    
    
12.     ' 引用工作表
    
13.     Set wsSource = ThisWorkbook.Sheets("Sheet1")
    
14.     Set wsResult = ThisWorkbook.Sheets("结果")
    
15.    
    
16.     ' 获取数据源范围 (从 A1 开始，包含标题)
    
17.     Set dataRange = wsSource.Range("A1").CurrentRegion
    
18.     rowCount = dataRange.Rows.Count
    
19.    
    
20.     ' 定义分数段规则 (根据需求修改)
    
21.     scoreSections = Array("3500-3000 (410-420)", "3000-2500 (420-432)", "2500-2000 (432-445)", _
    
22.                           "2000-1500 (445-460)", "1500-1200 (460-485)", "1200-900 (485-500)", _
    
23.                           "900-600 (500-521)", "600-300 (521-550)", "300- (550-9999)")
    
24.     Dim scoreLimits() As Variant
    
25.     scoreLimits = Array(410, 420, 432, 445, 460, 485, 500, 521, 550, 9999) ' 分数段的实际分界点
    
26.    
    
27.     ' 找到“班级”和“总分”列 (假设标题在第一行)
    
28.     colClass = 0
    
29.     colScore = 0
    
30.     For i = 1 To dataRange.Columns.Count
    
31.         If dataRange.Cells(1, i).Value = "班级" Then colClass = i
    
32.         If dataRange.Cells(1, i).Value = "总分" Then colScore = i
    
33.     Next i
    
34.    
    
35.     If colClass = 0 Or colScore = 0 Then
    
36.         MsgBox "未在标题中找到‘班级’列或‘总分’列，请检查标题！", vbExclamation
    
37.         Exit Sub
    
38.     End If
    
39.    
    
40.     ' 初始化用于存储结果的字典
    
41.     Set classDict = CreateObject("Scripting.Dictionary")
    
42.    
    
43.     ' 遍历数据源，从第二行开始
    
44.     For i = 2 To rowCount
    
45.         ' 确保 classKey 是字符串
    
46.         classKey = CStr(dataRange.Cells(i, colClass).Value)
    
47.         
    
48.         ' 确保分数是有效数字
    
49.         If IsNumeric(dataRange.Cells(i, colScore).Value) Then
    
50.             score = CDbl(dataRange.Cells(i, colScore).Value)
    
51.         Else
    
52.             score = 0 ' 如果分数无效，可以跳过或赋默认值
    
53.         End If
    
54.         
    
55.         ' 如果字典中不存在班级，则初始化班级的分段计数
    
56.         If Not classDict.exists(classKey) Then
    
57.             Dim sectionArray() As Long
    
58.             ReDim sectionArray(0 To UBound(scoreSections)) ' 初始化数组
    
59.             Dim sectionIndex As Long
    
60.             For sectionIndex = 0 To UBound(scoreSections)
    
61.                 sectionArray(sectionIndex) = 0
    
62.             Next sectionIndex
    
63.             classDict.Add classKey, sectionArray ' 添加键值对
    
64.         End If
    
65. 
    
66.         ' 根据分数找到对应的分数段，并计数加1
    
67.         For k = 0 To UBound(scoreLimits) - 1
    
68.             If score >= scoreLimits(k) And score < scoreLimits(k + 1) Then
    
69.                 Dim tempArray() As Long
    
70.                 tempArray = classDict(classKey) ' 获取当前班级的分段计数数组
    
71.                 tempArray(k) = tempArray(k) + 1
    
72.                 classDict(classKey) = tempArray ' 更新字典中的数组
    
73.                 Exit For
    
74.             End If
    
75.         Next k
    
76.     Next i
    
77.    
    
78.     ' 清空结果工作表
    
79.     wsResult.Cells.Clear
    
80.    
    
81.     ' 输出结果到‘结果’工作表
    
82.     wsResult.Cells(1, 1).Value = "班级"
    
83.     For j = 0 To UBound(scoreSections)
    
84.         wsResult.Cells(1, j + 2).Value = scoreSections(j)
    
85.     Next j
    
86.    
    
87.     rowOutput = 2
    
88.     For Each classKey In classDict.keys
    
89.         wsResult.Cells(rowOutput, 1).Value = classKey
    
90.         For k = 0 To UBound(scoreSections)
    
91.             wsResult.Cells(rowOutput, k + 2).Value = classDict(classKey)(k)
    
92.         Next k
    
93.         rowOutput = rowOutput + 1
    
94.     Next classKey
    
95.    
    
96.     MsgBox "统计完成！", vbInformation
    
97. End Sub

复制代码

戎马书生222

ai擅长使用cells