利用excel的内置宏编写“并班分班和统计分数”软件-成果展示-云南省威信县旧城中学 网校首页 校园新闻 通知公告 规章制度 考试招生 校园动态 新建校舍 校园文化 学校简介 校园活动 校园摄影 校庆专题 教师频道 名师风采 成果展示 教研活动 教师博客 学生园地 学生社团 优秀学生 学生作品 成绩榜单 校务公开 领导班子 校长在线 发展规划 党建园地 硬件学堂 软件教程 校园网建设 网络安全 心理健康 心理健康 心理咨询 心理测试 网校图库 营养餐图片 风景图片 女生宿舍 学校荣誉 领导班子 教师风采 优秀学生 学习交流 校内资源 网校空间 教师空间 职工空间 学生空间 家长空间 网校联谊 网校论坛 学习交流 休闲娱乐 我的校园 教师专版 班级主页 网校动态 当前位置： 首页 > 成果展示 > 利用excel的内置宏编写“并班分班和统计分数”软件 利用excel的内置宏编写“并班分班和统计分数”软件 2009年10月30日 10:48:46 来源:云南省威信县旧城中学万成龙 访问量：55次发布人:万成龙 利用excel的内置宏编写“并班分班和统计分数”软件，示例代码：Sub auto_open() ActiveWindow.Caption = ActiveWorkbook.FullName MsgBox "你好！新手使用提示！" & Chr(13) & "请将Visual Basic的安全级别设为“中”" & Chr(13) _ & "关闭后重新打开以便内置宏能正常运行" On Error Resume Next Application.CommandBars("myMenu").Delete '删除已有菜单 Set myMenu = Application.CommandBars.Add '添加新菜单 With myMenu .Visible = True '属性值（TRUE为显示） .Position = msoBarTop '将此菜单显示在顶部 .Name = "myMenu" End With '============================================= Set 子菜单 = myMenu.Controls.Add(Type:=msoControlPopup) '添加新按钮 子菜单.Caption = "学生成绩统计软件" Set KJ = 子菜单.Controls.Add(Type:=msoControlButton) '添加新按钮 With KJ .Caption = "学生成绩分表合并到一个总表" .OnAction = "学生成绩分表合并到一个总表" End With '============================================= Set KJ = 子菜单.Controls.Add(Type:=msoControlButton) '添加新按钮 With KJ .Caption = "成绩总表制作各班分表" .OnAction = "成绩总表制作各班分表" End With '============================================== Set KJ = 子菜单.Controls.Add(Type:=msoControlButton) '添加新按钮 With KJ .Caption = "计算平均分及格率小数点保留两位" .OnAction = "计算平均分及格率小数点保留两位" End With End Sub Sub auto_close() Application.CommandBars("myMenu").Delete '删除已有菜单 End Sub Sub 学生成绩分表合并到一个总表() 'MsgBox "您好！您选择了菜单一中的“学生成绩分表合并”按钮！", 64, "系统提示" 'If IsNumeric(userinto) = True Then Dim strname As String '保存目标表格的名称 Dim sum1 As String Dim i, j As Long Dim m, n As Long '记录行列数变化的中间过程 Dim x, y, s As Long '记录行列数变化的结果 Dim sumx, sumy As Long '用于记录目标表格已使用的行和列数 Dim mychoice As Integer '记录提示框的选择情况 Dim sum As Integer '用来判断所有表中有没有你输入的表名，为0表示无，为1表示有 'Dim sum As Boolean sum = 0 line1: strname = InputBox(" 各成绩表合并成一个总表软件" & Chr(13) & Chr(13) _ & "请输入目标表格的名称(可以是任意字符串)：" & Chr(13) _ & Chr(13) & "谨慎操作，目标表格1000行外的数据将被覆盖 ！" _ & Chr(13) & Chr(13) & " 请注意字母大小写 ！" _ & " wanchenglong") 'If strname = vbNullString Then Exit Sub For i = 1 To Sheets.Count '查找所有表中有没有你输入的表名 If Sheets(i).Name = strname Then sum = 1 '用过一次后，二次循环开始时应：sum = 0 End If ' MsgBox " " & i & " " & Sheets(i).Name & " " & strnam Next i If sum = 0 Then '如果总表名输入错误 mychoice = MsgBox("总表名：" & strname & " 输入错误 ！" & Chr(13) _ & " 是否继续 ！" & Chr(13) & " 请注意字母大小写 ！" _ , vbYesNo + vbQuestion + vbDefaultButton1) If mychoice = 6 Then GoTo line1 If mychoice = 7 Then Exit Sub End If If sum = 1 Then '如果总表名输入正确 sum = 0 sumy = 1 '先赋值为1，现在用于第一次进入时计算目标表格已使用的行和列数标志 For s = 1 To 30 '班级循环 line2: sum1 = InputBox("请输入想要合并班级表格名称：" & Chr(10) & "(可以是任意字符串)" _ & Chr(13) & Chr(13) & " 若关闭窗口程序将退出 ！") If sum1 = vbNullString Then mychoice = MsgBox("你没有输入表名：" & sum1 & Chr(13) & " 是否继续 ！" _ , vbYesNo + vbQuestion + vbDefaultButton1) If mychoice = 6 Then GoTo line2 If mychoice = 7 Then Exit Sub End If For i = 1 To Sheets.Count '查找所有表中有没有你输入的表名 If sum1 = Sheets(i).Name Then sum = True '用过一次后，二次循环开始时应：sum = 0 Next i If sum = False Then '如果分表名输入错误 mychoice = MsgBox("所有表中没有你输入的表名：" & sum1 & Chr(13) & " 是否继续 ！" _ , vbYesNo + vbQuestion + vbDefaultButton1) If mychoice = 6 Then GoTo line2 If mychoice = 7 Then Exit Sub End If If sum = True And sumy = 1 Then '是第一次输入且分表表名存在 For i = 1 To 5000 '就计算目标表格strname已使用的行和列数 For j = 1 To 5 '列 If Worksheets(strname).Cells(i, j).Value <> "" Then m = i n = j If x < m Then x = m If y < n Then y = n End If Next j Next i If x = 0 And y = 0 Then MsgBox "你输入的总表中没有数据 ！" & Chr(13) & "程序将从第一行开始输出 ！" End If sumx = x '保留行数供后面用 MsgBox "你输入的总表已有" & sumx & "行" & Chr(13) & "程序将从第" & sumx + 1 & "行开始输出 ！" sumy = sumy + 1 '自加1后，让程序第二次进入大循环时不这个if语句 End If x = 0 y = 0 For i = 1 To 1000 '就计算分表格已使用的行和列数 For j = 1 To 15 '列 If Worksheets(sum1).Cells(i, j).Value <> "" Then m = i n = j If x < m Then x = m If y < n Then y = n End If Next j Next i For i = 1 To x '循环将sum1班的(成绩)表复制到目标表格 Application.StatusBar = "正在处理总表第 " & sumx + i & " 行的数据..." Worksheets(sum1).Rows(i).Copy Sheets(strname).Rows(i + sumx) Next i sumx = sumx + x ' If sumy <> y Then sumy = y Application.StatusBar = "程序处理完成，谢谢使用！旧城中学万成龙 15925074976" mychoice = MsgBox(sum1 & " 成绩表" & " " & x & "行" & " " & y & "列" _ & " 复制完成 ！" & Chr(13) & " 总表现有" & sumx & "行" _ & Chr(13) & " 是否继续 ？" _ , vbYesNo + vbQuestion + vbDefaultButton1) If mychoice = 7 Then Exit Sub sum = 0 Next s End If End Sub Sub 成绩总表制作各班分表() 'MsgBox "您好！您选择了菜单一中的“成绩总表制作各班分表”按钮！", 64, "系统提示" Dim strname As String '总表表格的名称 Dim sum As Integer Dim sumnamex, sumnamey As Integer Dim i, j, m, n, x, y As Long 'i,j用于循环，m,n中间变量，x,y总表表格的已用横纵坐标 'Dim str(1 To 50) As String '定义字符串数组，装入分表班级名称 'Dim sum_str(1 To 50) As Integer '定义数组，装入各分表中已输入的行数 'Dim tongmingcishu(1 To 50) As Integer Dim s As Integer line1: strname = InputBox(" 分班软件 " & Chr(10) _ & "请输入总表表格的名称(可以是任意字符串)：" & Chr(13) _ & Chr(13) & Chr(13) & " 各分表可自动创建 ！" _ & Chr(13) & Chr(13) & Chr(13) & Chr(10) _ & " 请注意字母大小写 ！" _ & "yunnanweixin_jiuchengzhongxue_wanchenglong" _ & Chr(10) & " 2008年6月10日") For i = 1 To Sheets.Count '查找所有表中有没有你输入的表名 If Sheets(i).Name = strname Then sum = 1 '用过一次后，二次循环开始时应：sum = 0 End If Next i If sum = 0 Then '如果总表名输入错误 mychoice = MsgBox("总表名：" & strname & " 输入错误 ！" & Chr(13) _ & " 是否继续 ！" & Chr(13) & " 请注意字母大小写 ！" _ , vbYesNo + vbQuestion + vbDefaultButton1) If mychoice = 6 Then GoTo line1 If mychoice = 7 Then Exit Sub End If If sum = 1 Then '如果总表名输入正确，就计算总表表格strname已使用的行和列数 sum = 0 '将值还原为0，供下一次使用 For i = 1 To 2000 '行 For j = 1 To 5 '列 If Worksheets(strname).Cells(i, j).Value <> "" Then m = i n = j If x < m Then x = m If y < n Then y = n End If Next j Next i m = 0 n = 0 If x = 0 And y = 0 Then MsgBox "总表中没有数据 ！" Exit Sub End If End If For i = 1 To 5 '检测总表表格strname中“班级”所在的行和列，行数m,n供后面使用 For j = 1 To 15 If Worksheets(strname).Cells(i, j).Value = "班级" Then m = i n = j End If If m <> 0 Then Exit For '如果找到就及时退出循环 Next j If m <> 0 Then Exit For '如果找到就及时退出循环 Next i ReDim sum_str(x) ReDim tongmingcishu(x) For i = m + 1 To x 'sumname '在"班级"所在列查找下面数据（班级名称）所有表中是否存在 For j = 1 To Sheets.Count Application.StatusBar = "正在处理总表第 " & i & " 行的数据..." & "分表" & Sheets(j).Name & "的数据" If Worksheets(strname).Cells(i, n).Value = "" Then MsgBox "程序发现有值的" & i & "行" & n & "列 " & "“班级”下面是无班级名称！" & Chr(13) & Chr(13) _ & "请你仔细检查：若出现在中间，则添加班级名称或删除该行后重做！" _ & Chr(13) & Chr(13) & "若在结尾，那么，分班已经完成，点击“确定”程序退出！" Application.StatusBar = "程序处理完成，谢谢使用！旧城中学万成龙" Exit Sub End If If CStr(Worksheets(strname).Cells(i, n).Value) = Sheets(j).Name Then sum = 1 tongmingcishu(j) = tongmingcishu(j) + 1 If tongmingcishu(j) = 1 Then For s = 1 To m '利用sum作一次循环并把总表中的“班级”所在行即表头复制到该表 Worksheets(strname).Rows(s).Copy Sheets(j).Rows(s) Next s sum_str(j) = sum_str(j) + m End If '第一次同名行复制应复制到第m+2行 Worksheets(strname).Rows(i).Copy Sheets(Sheets(j).Name).Rows(sum_str(j) + 1) sum_str(j) = sum_str(j) + 1 If tongmingcishu(j) > 1 Then Exit For End If Next j If sum = 0 Then '所有表中不存在该分表，就自动创建并命名 ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(Sheets.Count) ThisWorkbook.Sheets(Sheets.Count).Name = CStr(Worksheets(strname).Cells(i, n).Value) sum_str(Sheets.Count) = 1 '以下将str(sheets.count)改为Sheets.Count).Name就可不用str(j) Worksheets(strname).Rows(i).Copy _ Sheets(Sheets(Sheets.Count).Name).Rows(sum_str(Sheets.Count) + m) End If sum = 0 Next i Application.StatusBar = "程序处理完成，谢谢使用！旧城中学万成龙 15925074976" End Sub Sub 删除此菜单() On Error Resume Next Application.CommandBars("myMenu").Delete '删除已有菜单 End Sub Sub 计算平均分及格率小数点保留两位() 'MsgBox "您好！您选择了菜单一中的“成绩总表制作各班分表”按钮！", 64, "系统提示" Dim strname As String '总表表格的名称 Dim sum As Integer Dim i, j, m, n, x, y As Long 'i,j用于循环，m,n中间变量，x,y总表表格的已用横纵坐标 Dim s As Integer Dim sumstr As String line1: strname = InputBox(" 计算总表及分表的：平均分等.... " _ & Chr(10) & "请输入总表表格的名称(可以是任意字符串)：" & Chr(13) _ & Chr(13) & Chr(13) & " “语文”应输在各科目的左边！" _ & Chr(10) & "分表表头与总表表头一致 最好是使用分班软件！" _ & "yunnanweixin_jiuchengzhongxue_wanchenglong" _ & Chr(10) & " 2009年5月10日") For i = 1 To Sheets.Count '查找所有表中有没有你输入的表名 If Sheets(i).Name = strname Then sum = 1 '用过一次后，二次循环开始时应：sum = 0 End If Next i If sum = 0 Then '如果总表名输入错误 mychoice = MsgBox("总表名：" & strname & " 输入错误 ！" & Chr(13) _ & " 是否继续 ！" & Chr(13) & " 请注意字母大小写 ！" _ , vbYesNo + vbQuestion + vbDefaultButton1) If mychoice = 6 Then GoTo line1 If mychoice = 7 Then Exit Sub End If If sum = 1 Then '如果总表名输入正确，就计算总表表格strname 1-10行总的已使用的列数y,供后面使用 sum = 0 '将值还原为0，供下一次使用 For i = 1 To 10 '行 For j = 1 To 20 '列 If Worksheets(strname).Cells(i, j).Value <> "" Then m = i n = j If x < m Then x = m If y < n Then y = n End If Next j Next i '检测到总表中最大使用行列数为：(x,y) m = 0 n = 0 If x = 0 And y = 0 Then MsgBox "总表中没有数据 ！" Exit Sub End If End If For i = 1 To 10 '检测总表表格strname中“语文”所在的行和列，行数m,n供后面使用 For j = 1 To 30 If Worksheets(strname).Cells(i, j).Value = "语文" Then m = i '语文所在行数,后面的“平均分”“标准差”等应打在前一列 n = j '语文所在列数 End If If m <> 0 Then Exit For '如果找到就及时退出循环 Next j If m <> 0 Then Exit For '如果找到就及时退出循环 Next i For j = 2 To Sheets.Count For i = 1 To y '用此循环检测标题行是否一致 Workbooks(1).Sheets(j).Activate Cells(m, i).Select If ThisWorkbook.Sheets(1).Cells(m, i).Value <> ThisWorkbook.Sheets(j).Cells(m, i).Value Then MsgBox " 标题行不一致 ！" & Chr(13) _ & "工作表 " & ThisWorkbook.Sheets(1).Name & "与工作表 " & ThisWorkbook.Sheets(j).Name & " 的值“" _ & ThisWorkbook.Sheets(1).Cells(m, i).Value & "” 不等于 “" & ThisWorkbook.Sheets(j).Cells(m, i).Value _ & "”" & Chr(13) & "点击确定，程一序退出！请检查或使用分班软件后重新运行！" Exit Sub End If Next i Next j ReDim yes_kemusuozailie(y) 'y用来定义此数组的大小 ReDim no_kemusuozailie(y) For i = 1 To y Workbooks(1).Sheets(strname).Activate Cells(m, i).Select sumstr = Worksheets(strname).Cells(m, i).Value If sumstr = "语文" Or sumstr = "数学" Or sumstr = "英语" Or sumstr = "政治" _ Or sumstr = "思品" Or sumstr = "物理" Or sumstr = "化学" Or sumstr = "历史" _ Or sumstr = "地理" Or sumstr = "生物" Or sumstr = "思想品德" _ Then yes_kemusuozailie(i) = i If sumstr = "语文" Then MsgBox "语文所在位置为：第" & m & "行" & "第" & yes_kemusuozailie(i) & "列！" & Chr(13) _ & "要进行统计! 并且“平均分，标准差”等字样在前一列输出！" Else: MsgBox sumstr & "所在位置为：第" & m & "行" & "第" & yes_kemusuozailie(i) & "列！" & "要进行统计!" End If Else: no_kemusuozailie(i) = i MsgBox sumstr & "所在位置为：第" & m & "行" & "第" & no_kemusuozailie(i) & "列！" & "将不作统计!" End If Next i Dim cx, co, g, sum1 As Long i = ThisWorkbook.Sheets.Count For j = 1 To i 'Worksheets(j).Visible = True k = ThisWorkbook.Sheets(j).Range("C65536").End(xlUp).Row + 1 co = y 'ThisWorkbook.Sheets(j).Cells(1, 256).End(xlToLeft).Column - 1 Sheets(j).Activate ThisWorkbook.Sheets(j).Cells(k + 1, n - 1).Value = "总分" If 1 = j Then ThisWorkbook.Sheets(j).Cells(k + 2, n - 1).Value = "年级平均分" Else ThisWorkbook.Sheets(j).Cells(k + 2, n - 1).Value = "平均分" End If ThisWorkbook.Sheets(j).Cells(k + 3, n - 1).Value = "及格数" ThisWorkbook.Sheets(j).Cells(k + 4, n - 1).Value = "及格率" ThisWorkbook.Sheets(j).Cells(k + 5, n - 1).Value = "最高分" ThisWorkbook.Sheets(j).Cells(k + 6, n - 1).Value = "最低分" ThisWorkbook.Sheets(j).Cells(k + 7, n - 1).Value = "全距" ThisWorkbook.Sheets(j).Cells(k + 8, n - 1).Value = "标准差" sum1 = n + 3 For cx = n To y '从语文所在列循环到总使用列数y If cx <> no_kemusuozailie(cx) Then ThisWorkbook.Sheets(j).Cells(k + 1, cx) = Application.WorksheetFunction.sum(Range(Cells(m + 1, cx), Cells(k, cx))) 'Range(ThisWorkbook.Sheets(j).Cells(k + 1, cx)).NumberFormat = "0.00" ThisWorkbook.Sheets(j).Cells(k + 2, cx) = Round(Application.WorksheetFunction.Average(Range(Cells(m + 1, cx), Cells(k - 1, cx))), 2) If cx < sum1 Then g = ">=72" Else g = ">=60" ThisWorkbook.Sheets(j).Cells(k + 3, cx) = Application.WorksheetFunction.CountIf(Range(Cells(m + 1, cx), Cells(k - 1, cx)), g) ThisWorkbook.Sheets(j).Cells(k + 4, cx) = Round(ThisWorkbook.Sheets(j).Cells(k + 3, cx).Value / (k - m - 1), 3) ThisWorkbook.Sheets(j).Cells(k + 5, cx) = Application.WorksheetFunction.Max(Range(Cells(m + 1, cx), Cells(k - 1, cx))) ThisWorkbook.Sheets(j).Cells(k + 6, cx) = Application.WorksheetFunction.Min(Range(Cells(m + 1, cx), Cells(k - 1, cx))) ThisWorkbook.Sheets(j).Cells(k + 7, cx) = ThisWorkbook.Sheets(j).Cells(k + 5, cx).Value - ThisWorkbook.Sheets(j).Cells(k + 6, cx).Value ThisWorkbook.Sheets(j).Cells(k + 8, cx) = Round(Application.WorksheetFunction.StDev(Range(Cells(m + 1, cx), Cells(k - 1, cx))), 2) End If Next cx Sheets(j).Activate Cells(k + 4, n).Select Next j Application.StatusBar = "程序处理完成，谢谢使用！旧城中学万成龙 15925074976" End Sub 上一篇：小学语文尝试探究性阅读教学模式初探 下一篇：旧城中学115班交通安全教育教案 评论区 发表评论 在此发表评论！ 评论仅供会员表达个人看法，并不表明网校同意其观点或证实其描述 关闭 搜索框 搜索 最新文章 不仅有免费的午餐,还是免费的一日三餐 综合利用地方资源的校本课程开发应用研究 旧城中学调研报告 名人名言 学会感激 学会清空 学会宽容 心态的力量 一个大学生的讲演，是中国人都会动容 旧城中学深入学习实践科学发展观实施方案 会员风采 更多>> 万成龙 马开凤 魏勋友 王毅 康世阳 马世权 李清富 OA办公 |会员注册 |关于我们 |网站地图 |版权声明 |友情链接 |联系我们 |帮助中心 Copyright 2006-2013 jczhongxue.30edu.com , All Rights Reserved中国现代教育网 提供技术支持 违法和不良信息举报中心 京公网安备11010502021722 云南省威信县旧城中学 版权所有 中华人民共和国电信经营许可证 京ICP备13002626号-1 联系地址: