1、特优人数=记录数特优率Dim kemushu As Integer kemushu科目数Private Sub anew_Click（） Rem 菜单条“退出”-菜单项“重新评价”If Dir（E:教学质量评价系统指标及权重.xls） Then Kill 删除End If教学质量评价系统指标及标准.xls End SubPrivate Sub create_Click（） Rem 菜单条“评价程序”-菜单项“创建评价表” If Dir（教学质量评价系统教学质量评价表.xls Set xlApp = CreateObject（Excel.Application） Set xlBook = xlA
2、pp.Workbooks.Open（） 打开 Set xlSheet = xlBook.Worksheets（1） xlSheet.Activate xlApp.Sheets（1）.Name = 教学质量评价表第1张工作表命名。 xlBook.RunAutoMacros （xlAutoOpen） 运行自动开启宏。 xlSheet.Range（A1:W128）.HorizontalAlignment = xlCenter Rem 上句：水平居中.下句：垂直居中。）.VerticalAlignment = xlCenter xlSheet.Columns（A）.ColumnWidth = 5 A列
3、，列宽定为5B）.ColumnWidth = 4C）.ColumnWidth = 7DE）.ColumnWidth = 5F:GHI:MNO:T kemushu = 7 * 修改 Dim i As Integer Dim kongge As Integer kongge = 8 两张表之间空8格。* 修改 For i = 1 To kemushuA1）.Select Call Macro1（i, kongge） 调用宏1画表格。 With xlBook.Worksheets（1） .Range（ & （kongge * （i - 1） + 1） &: （kongge * （i - 1） + 1
4、）.Merge （kongge * （i - 1） + 2） & （kongge * （i - 1） + 3）.Merge 合格单元格 （kongge * （i - 1） + 3）.Merge （kongge * （i - 1） + 2）.MergeQRS End With （kongge * （i - 1） + 1） = 古培中学2014年上学期考试成绩册 （kongge * （i - 1） + 1）.Font.Bold = True 粗体字 （kongge * （i - 1） + 1）.Font.Size = 18 设置字体大小 （kongge * （i - 1） + 2） = 科 （Ch
5、r（13） & Chr（10） &目班级任教应参基 础 学 历 水 平 （ 0.9 ）特 长 发 展 水 平0.1 （kongge * （i - 1） + 3） = 合格F合格率合格分优秀I优秀率J优秀分K生总分L生均分生得分特优O特优率P特优分特长分评价名次得分 Next xlBook.Save MsgBox 评价表已经创建好。 Call AppClose 调用关闭过程。 Else教学质量评价系统教学质量评价表.xls ,文件不存在。 End IfPrivate Sub exit_Click（） EndPrivate Sub Form_Load（） Rem 定义动态数组 Dim achiev
6、ement（） As Integer 定义动态数组,achievement 成绩 Dim jigefenshu（） As Integer 及格分数 Dim youxiufenshu（） As Integer 优秀分数。 Dim teyoufenshu（） As Integer 特优分数。 Dim kemujigerenshu（） As Integer 科目及格人数 Dim kemuyouxiurenshu（） As Integer 科目优秀人数 Dim kemuteyourenshu（） As Integer 科目特优人数 Rem Dim records As Integer Rem “评价准
7、备”菜单条-菜单项“新建工作薄”Private Sub newbooks_Click（） Then 如文件在，不新建。 工作薄指标及权重、 _指标及标准已创建。（Chr（13） & Chr（10） 是回车与换行符。 xlApp.Workbooks.Add （1） 新建工作薄,每个工作薄只有1张工作表。 xlApp.ActiveWorkbook.SaveAs 保存薄。教学质量评价系统科任教师表.xls Rem 科任教师表.xls 存在，不做任何操作。 Rem 一次可创建多个工作薄。 在“E:教学质量评价系统”,已经新建如下工作薄指标及权重.xls与指标及标准.xls科任教师表.xls与教学质量评
8、价表.xls xlApp.quit Set xlApp = NothingRem “退出”菜单条Private Sub quit_Click（）Rem 菜单条“评价准备”-菜单项“指标及权重”Private Sub quota_Click（）指标及权重K20 Worksheets（1）.Columns（B:）.ColumnWidth = 11 B列到I列，列宽设定为11字符，5个汉字。 xlSheet.Cells.Item（1, 2） = 及格率权值Item 项目，条，条款 xlSheet.Cells.Item（1, 3） = 优秀率权值 xlSheet.Cells.Item（1, 4） =
9、生均分权值 xlSheet.Cells.Item（1, 5） = 特优率权值 xlSheet.Cells.Item（1, 6） = 特长权值 xlSheet.Cells.Item（1, 7） = 合计 xlSheet.Cells.Item（2, 1） = 权重 Rem 权重默认值 xlSheet.Cells.Item（2, 2） = 0.6 及格率60%（及以下都是主观设定），B列2行 xlSheet.Cells.Item（2, 3） = 0.2 优秀率20% C列2行 xlSheet.Cells.Item（2, 4） = 0.1 生均分10% xlSheet.Cells.Item（2, 5）
10、 = 0.05 特优率5% xlSheet.Cells.Item（2, 6） = 0.05 特长，评价总分共100分。 F列2行 Worksheets（1）.Range（G2）.Formula = =SUM（B2:F2）在第1张工作表，单元格G2中，加入公式并计算。 xlSheet.Cells.Item（6, 2） = 及格率 xlSheet.Cells.Item（6, 3） = xlSheet.Cells.Item（6, 4） = xlSheet.Cells.Item（7, 1） = 主观值 xlSheet.Cells.Item（7, 2） = 0.8 及格率，主观定为80% xlSheet
11、.Cells.Item（7, 3） = 0.2 优秀率，主观定为20% xlSheet.Cells.Item（7, 4） = 0.05 特优率，主观定为5% Rem xlApp.Visible = True 工作薄设为可见。指标及权重已经设置完毕。 xlBook.RunAutoMacros （xlAutoClose） 关闭自动开启宏。Rem 菜单条“评价准备”-菜单项“指标及标准”Private Sub standard_Click（）Rem 第一步：从*年级成绩表.xls中复制数据。 Call copyData（achievementBook） 参数：achievementBook在“通用”
12、部分定义。 请先运行评价准备下的新建工作薄,再运行指标及权重菜单项Rem 第二步：排序数据，确定及格分、优秀分、特优分 Call reorderPublic Sub copyData（achievementBook As String） Rem 此过程复制数据教学质量评价系统*成绩表.xls achievementBook = Dir（ Rem achievementBook2 成绩表，xls文件请复制*年级成绩表.xls,粘贴到：教学质量评价系统 achievementBook） xlApp.Workbooks（achievementBook）.Worksheets（Sheet1）.Rang
13、e（D2: xlSheet. _ UsedRange.Rows.Count）.Copy Rem D-K共8列，九年级有7个科目成绩。成绩表第1列是学号，第2列是姓名，第3列是班级， Rem 第4列才是语文成绩。八年级有8个科目成绩。 xlApp.Workbooks（achievementBook）.ActiveSheet.Paste Destination _ :=xlApp.Workbooks（指标及标准.xls）.Worksheets（1）.Range（B1 Rem xlApp.SaveWorkspace此句不好，会产生xlw文件。 clearClipboard 调用清除剪贴板函数。 Re
14、m Application.CutCopyMode = False 清除剪贴板上的信息，还是未清除。 xlApp.Workbooks（achievementBook）.Close SaveChanges:=False xlApp.Workbooks（）.Close SaveChanges:=True End SubPublic Sub reorder（） Rem 此过程，排序数据，按降序 Dim captionNumber As Integer captionNumber 工作表中标题行有几行。 Dim columnNo As String columnNo= ABCDEFGHIGK 列标识字符。 Dim couNo As String couNo 存放从字符串columnNo中截取得到的一个字符。转“通用”定义 Rem * Rem 参数修改部分 captionNumber = 1 复制得到的成绩表的标题行只有1行：学号，班级，语文，数学. columnNo = ABCDEFGHIJKLMNOPQRSTUVWXYZ Rem 复制得到的工作表，A列为空，B列为语文成绩，C列为数学成绩，D列为英语成绩. Rem 注意：成绩从B列开始。参加评价共有7个科目：语文、数学、英语、物理、化学、历史、政治 Rem Set xlApp = CreateObject（创建了没有工作表的工作
