ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 14310|回复: 34

分数段统计(数组)(vba)

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2011-8-7 21:58 | 显示全部楼层 |阅读模式
本帖最后由 lzqlaj 于 2012-10-8 09:10 编辑

分数段统计(vba)
看到论坛上好多网友讨论统计分数段的问题,一些教育工作者经常要统计分数段,其中除了部分人用公式统计外,也有一部分不会用excel,用人工数的,本人深受其害,不愿意去数数,做了这个小工具,希望大家批评指正。
这是我在 http://club.excelhome.net/thread-599282-1-1.html 的帖子,不能编辑了,今天晚上用数组重做了这个工具,只好发新帖。
新功能;在成绩表里贴入成绩,在sheet1里点击“统计”,设置好上下限即可(班级自动生成,升序排列)。
2012年10月8日,再次更新:
1、自动查找班级、总分列。
2、添加清空按钮。
3、修正自动按班级排序。

4、添加"总计"功能。
5、附件已更新为121008。请下载最新附件。

其它帖子:
成绩录入工具(vb)
http://club.excelhome.net/thread-744536-1-1.html
空行操作(“插入空行”)
http://club.excelhome.net/thread-590404-1-1.html
[分享] (无意中发现的)罗刚君 底端标题生成工具(开放源码含附件)
http://club.excelhome.net/thread-601577-1-1.html
[源码全部公开] 分数段统计(vba)
http://club.excelhome.net/thread-599282-1-1.html
搜狗文本词库的制作(vb)
http://club.excelhome.net/thread-670925-1-1.html
汉字与区位码转换(vb版)
http://club.excelhome.net/thread-670918-1-1.html
[源码全部公开] 区位码与汉字相互转换
http://club.excelhome.net/thread-601351-1-1.html
优盘禁用工具
http://club.excelhome.net/thread-495008-1-1.html
[源码全部公开] 工资条通用生成程序(也可分考场)
http://club.excelhome.net/thread-487664-1-1.html
[转帖] 把excel追加导入到access数据库
http://club.excelhome.net/thread-745574-1-1.html
[转帖] 删除mbd数据库中所有记录
http://club.excelhome.net/thread-745139-1-1.html
[转帖] VB中对数据库的各种操作
http://club.excelhome.net/thread-745136-1-1.html
[转帖] VB把access数据库里的表导出成EXCEL表
http://club.excelhome.net/thread-745132-1-1.html





补充内容 (2016-5-25 23:06):
改编成:名次段统计(vba),http://club.excelhome.net/thread-1280059-1-1.html,欢迎使用。

分数段统计(数组)121008.rar

280 Bytes, 下载次数: 2178

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-8-8 19:38 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-6-10 08:57 | 显示全部楼层
代码重新调整了一下,嘿嘿。


Private Sub CommandButton1_Click()

    Dim Sh, xi, jg, d As Integer
    Dim Row1, Arr1, Arr2, Arr11
    Sh = Val(TextBox1.Text)
    xi = Val(TextBox2.Text)
    jg = Val(TextBox3.Text)
    d = (Sh - xi) / jg
    Row1 = Sheets("成绩表").Range("B65536").End(xlUp).Row
    Arr1 = Sheets("成绩表").Range("a2:B" & Row1)
    Set r = Sheets("成绩表").Range("a2:a" & Row1)
    If TextBox1.Text = "" Or TextBox2.Text = "" Then
        MsgBox ("上、下限未全部设置"): Exit Sub
    Else
        Application.ScreenUpdating = False
        Cells.Clear
        If zx.Value = True Then
            'Columns(4).Insert
            Cells(1, 3) = "班级"
            Cells(1, 4) = Sh & "以上"
            For i = 1 To d
                Cells(1, 4 + i) = (Sh - jg * i) & "≤x<" & (Sh - jg * (i - 1))
            Next i
            Cells(1, 5 + d) = xi & "以下"
            Set dic = CreateObject("scripting.dictionary")
            For Each rng In r
                tmp = rng.Value
                If dic.exists(tmp) Then
                    dic(tmp) = dic(tmp) + 1
                Else
                    dic.Add tmp, 1
                End If
            Next
            Cells(2, 3).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
            Cells(2, 3).Resize(dic.Count, 1).Sort key1:=Cells(2, 3), order1:=xlAscending, HEADER:=xlNo
            Arr2 = Range("c2:c" & (1 + dic.Count))
            ReDim Arr11(1 To UBound(Arr2), 1 To d + 2)
            For i = 1 To UBound(Arr2)
                For k = 1 To d + 2
                    w = 0
                    For j = 1 To UBound(Arr1)
                        If k = 1 Then
                            If Arr1(j, 1) = Arr2(i, 1) And Arr1(j, 2) >= Sh Then w = w + 1
                        End If
                        If k = d + 2 Then
                            If Arr1(j, 1) = Arr2(i, 1) And Arr1(j, 2) < xi Then w = w + 1
                        End If
                        If k > 1 And k < d + 2 Then
                            If Arr1(j, 1) = Arr2(i, 1) And Arr1(j, 2) >= (Sh - jg * (k - 1)) And Arr1(j, 2) < (Sh - jg * (k - 2)) Then w = w + 1
                        End If
                    Next j
                    Arr11(i, k) = w
                Next k
            Next i
            Cells(2, 4).Resize(dic.Count, d + 2) = Arr11
        End If
        If hx.Value = True Then
            Cells(1, 3) = "班级"
            Cells(2, 3) = Sh & "以上"
            For i = 1 To d
                Cells(i + 2, 3) = (Sh - jg * i) & "≤x<" & (Sh - jg * (i - 1))
            Next i
            Cells(3 + d, 3) = xi & "以下"
            Set dic = CreateObject("scripting.dictionary")
            For Each rng In r
                tmp = rng.Value
                If dic.exists(tmp) Then
                    dic(tmp) = dic(tmp) + 1
                Else
                    dic.Add tmp, 1
                End If
            Next
            Cells(1, 4).Resize(1, dic.Count) = (dic.keys)
            With Cells(1, 4).Resize(1, dic.Count)
                For i = 0 To dic.Count - 1
                    .Offset(i, 0).Sort key1:=Cells(1, 4).Offset(i, 0), order1:=xlAscending, Orientation:=xlLeftToRight
                Next
            End With
            Arr2 = Cells(1, 4).Resize(1, dic.Count)
            ReDim Arr2(1 To dic.Count)
            For i = 1 To dic.Count   '填写班级
                Arr2(i) = Cells(1, i + 3)
            Next i
            ReDim Arr11(1 To UBound(Arr2), 1 To d + 2)
            For i = 1 To UBound(Arr2)
                For k = 1 To d + 2
                    w = 0
                    For j = 1 To UBound(Arr1)
                        If k = 1 Then
                            If Arr1(j, 1) = Arr2(i) And Arr1(j, 2) >= Sh Then w = w + 1
                        End If
                        If k = d + 2 Then
                            If Arr1(j, 1) = Arr2(i) And Arr1(j, 2) < xi Then w = w + 1
                        End If
                        If k > 1 And k < d + 2 Then
                            If Arr1(j, 1) = Arr2(i) And Arr1(j, 2) >= (Sh - jg * (k - 1)) And Arr1(j, 2) < (Sh - jg * (k - 2)) Then w = w + 1
                        End If
                    Next j
                    Arr11(i, k) = w
                Next k
            Next i
            Cells(2, 4).Resize(d + 2, dic.Count) = Application.Transpose(Arr11)
        End If
    End If
    Cells.ColumnWidth = 4.25
    Cells.Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton2_Click()
    Me.Hide
End Sub

TA的精华主题

TA的得分主题

发表于 2012-6-10 23:42 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
好好看看,非常好的帖子

TA的精华主题

TA的得分主题

发表于 2012-7-17 00:35 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2012-10-6 22:13 | 显示全部楼层
分数段统计.rar (22.76 KB, 下载次数: 196)
两个问题:1,纵向显示,班级没有排序  2,应该在最后班级结束处加上总计吧。
同时:我们的成绩不是班级过了就是总分,而是班级过后是语数外,物 然后才是 总分
头像被屏蔽

TA的精华主题

TA的得分主题

发表于 2012-10-6 23:30 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-10-7 10:56 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
foreversun 发表于 2012-10-6 22:13
两个问题:1,纵向显示,班级没有排序  2,应该在最后班级结束处加上总计吧。
同时:我们的成绩不是班级 ...

附件已更新,可自动查找班级、总分。班级排序已经修正。总计只是一个函数填充而已,这个没功能没添加,你自己填充函数公式吧。附件在1楼。

TA的精华主题

TA的得分主题

 楼主| 发表于 2012-10-7 10:58 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
baigangliao 发表于 2012-10-6 23:30
Cells(2, 3).Resize(dic.Count, 1).Sort key1:=Cells(2, 3), order1:=xlAscending, HEADER:=xlNo

附件已更新,问题已解决。谢谢提醒。。

TA的精华主题

TA的得分主题

发表于 2012-10-7 12:09 来自手机 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 18:25 , Processed in 0.056576 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表