巧用Excel VBA进行登分录入考试成绩.docx
《巧用Excel VBA进行登分录入考试成绩.docx》由会员分享，可在线阅读，更多相关《巧用Excel VBA进行登分录入考试成绩.docx（16页珍藏版）》请在冰豆网上搜索。
巧用ExcelVBA进行登分录入考试成绩
巧用ExcelVBA进行考试成绩登分录入
广西桂林市阳朔县外语实验中学莫孟福
本程序下载下址
登分是每次考试后不可少的工作，21世纪各种考试的成绩统计已经进入电脑时代，但登分工作却大多停留于“刀耕火种”年代——预先整理试卷、按座位号登分，重复数据手工查找……。
笔者所在学校甚至还在使用最原始方法——评卷、拆卷、分班、登分。
班级多，人数多，时间紧，不仅使得工作人员疲倦不堪，同时也出现不少的错误数据。
鉴于此，笔者根据本校实际情况，用ExcelVBA编了个程序，免去了按学号顺序登分之苦，也免去了登分前整理试卷之累，甚至避免了按记分册登分的查找不便之处，让教师可左手翻试卷，右手敲键盘登分，一气呵成。
程序需建立花名册（如图1）及登分（如图2）两个工作表，工作人员先在花名册工作表录入考生信息，如学号（或考号）、姓名、班级等，然后在登分工作表的第一列输入分数、第二列输入考生信息进行模糊查找，查找结果通过列表显示，你只需轻按键盘（Up、Down、Left、Right、Enter、Esc键）选择正确的学生信息即可快速录入。
图1
图2
程序代码简单，先在登分工作表新建两个ActiveX控件——文本框TextBox1和列表框ListBox1，然后为他们添加相关事件代码。
我们在工作表第二列激活的单元格里输入查询的关键字其实是一种错觉，实际上是用一个与单元格一模一样的文本框覆盖着单元格，其实输入到的是文本框内，为使文本框及列表框能随单元格的选择而相应改变，必须为工作表添加单元格激活事件代码：
PrivateSubWorksheet_SelectionChange（ByValTargetAsRange）
OnErrorResumeNext'设置容错语句，防止操作出错时卡住
Application.EnableEvents=False'禁用事件
IfListBox1.VisibleThenListBox1.Visible=False
IfTextBox1.VisibleThenTextBox1.Visible=False
ListBox1.Clear'清除列表
WithTarget'激活的单元格
If.Column=2And.Row<>1Then'属于第二列，并且不是第一行
'设置TextBox1跟随单元格，如大小、位置、填充颜色、字体等要一致
TextBox1.Top=.Top+1
TextBox1.Left=.Left+1
TextBox1.Width=.Width-1
TextBox1.Height=.Height-0.1
'设置ListBox1位置跟随单元格变化
If.Row>ActiveWindow.VisibleRange.Rows.Count+ActiveWindow.VisibleRange.Row-5Then
ListBox1.Top=.Top-ListBox1.Height
Else
ListBox1.Height=.Height*5
ListBox1.Top=.Top+.Height+1
EndIf
ListBox1.Left=.Left+.Width+1
ListBox1.Width=.Width*（Sheet3.UsedRange.Columns.Count+1）
TextBox1.BackColor=.Interior.Color
TextBox1.ForeColor=.Font.Color
TextBox1.Font.Size=.Font.Size
TextBox1=.Value
TextBox1.Visible=True
ListBox1.Visible=True
TextBox1.Activate
CallTextBox1_Change
TextBox1.SelStart=0
TextBox1.SelLength=1000
EndIf
EndWith
Application.EnableEvents=True
EndSub
为了能随着输入查询关键字不断的进行模糊查找，需为TextBox1添加Change事件，并用Find方法实现查找功能。
代码如下：
PrivateSubTextBox1_Change（）
DimfirstAddressAsString,rngAsRange,Arr（）AsString'声明需要用到的变量
TextBox1.Visible=True
ListBox1.Visible=True
ListBox1.Clear
TextBox1.TopLeftCell.Value=TextBox1.Text'激活的单元格内容与文本框一致
IfTextBox1=""ThenExitSub
K=-1
WithWorksheets（"花名册"）.UsedRange
L=.Columns.Count+.Column–1'总列数
'按值模糊查找
Setrng=.Find（TextBox1.Text,LookIn:
=xlValues,Lookat:
=xlPart）
IfNotrngIsNothingThen'如果找到目标
firstAddress=rng.Address'记录第一个找到单元格的地址
Do'继续查找，直到找到的单元格地址等于刚才记录的单元格地址时停止
k=k+1
RedimPreserveArr（k）'重新定义数组
'查找结果读入数组
Arr（k）=.Cells（rng.Row,1）
Fori=2ToL
Arr（k）=Arr（k）&vbTab&.Cells（rng.Row,i）
Next
Setrng=.FindNext（rng）'查找下一个
LoopWhilerng.Address<>firstAddress
ListBox1.List=Arr'查找结果写入列表框
EndIf
EndWith
EndSub
为使文本框及列表框能响应Up、Down、Left、Right、Enter、Esc键，需为TextBox1和ListBox1添加KeyDown事件代码。
PrivateSubListBox1_KeyDown（ByValKeyCodeAsMSForms.ReturnInteger,ByValShiftAsInteger）
OnErrorResumeNext'设置容错语句，防止操作出错时卡住
SelectCaseKeyCode
Case13'回车Enter键
IfListBox1.ListCount>0Then
IfListBox1.Text=""ThenListBox1.ListIndex=0'如果没有选中项目，默认选中第一个项目
DimArr
Arr=Split（ListBox1.Value,vbTab）'将选中的项目文本转换为数组
WithTextBox1
.Visible=False
.TopLeftCell.Value=.Text'当前单元格内容为文本框内容
'将选中项目内容写入工作表
With.TopLeftCell.Offset（0,1）.Resize（1,UBound（Arr））
.Value=Arr
.Value=.Value
EndWith
.TopLeftCell.Offset（1,0）.Select'激活当前单元格的向下的一个单元格
EndWith
KeyCode=0
EndIf
Case37'Left向左键
TextBox1.Activate'激活文本框以输入查询关键字
Case27'Esc取消
TextBox1.Visible=False
ListBox1.Visible=False
EndSelect
EndSub
PrivateSubTextBox1_KeyDown（ByValKeyCodeAsMSForms.ReturnInteger,ByValShiftAsInteger）
OnErrorResumeNext
DimArr
WithTextBox1
SelectCaseKeyCode
Case38'UP向上键
'激活当前单元格的上一单元格
.Visible=False
.TopLeftCell.Value=.Text
.TopLeftCell.Offset（-1,0）.Select
KeyCode=0
Case13'Enter回车
'输入列表框第一个项目内容至工作表并激活当前单元格的下一单元格
IfListBox1.ListCount>0Then
Arr=Split（ListBox1.List（0）,vbTab）
.Visible=False
.TopLeftCell.Value=.Text
With.TopLeftCell.Offset（0,1）.Resize（1,UBound（Arr））
.Value=Arr
.Value=.Value
EndWith
.TopLeftCell.Offset（1,0）.Select
KeyCode=0
EndIf
Case40'Down向下键
'激活当前单元格的下一单元格
.Visible=False
.TopLeftCell.Value=.Text
.TopLeftCell.Offset（1,0）.Select
KeyCode=0
Case37'Left向左键
'输入列表框第一个项目内容至工作表并激活当前单元格的左一单元格
.Visible=False
IfListBox1.ListCount>0Then
Arr=Split（ListBox1.List（0）,vbTab）
.TopLeftCell.Value=.Text
With.TopLeftCell.Offset（0,1）.Resize（1,UBound（Arr））
.Value=Arr
.Value=.Value
EndWith
EndIf
.TopLeftCell.Offset（0,-1）.Select
KeyCode=0
Case39'Right向右键
ListBox1.Activate'激活列表框
Case27'Esc取消
.Visible=False
ListBox1.Visible=False
Selection.Select
EndSelect
EndWith
EndSub
为了能用鼠标双击点选项目实现输入，效果等同按下Enter键，需为ListBox1添加DblClick事件代码。
PrivateSubListBox1_DblClick（ByValCancelAsMSForms.ReturnBoolean）
OnErrorResumeNext'设置容错语句，防止操作出错时卡住
IfListBox1.ListCount>0Then
IfListBox1.Text=""ThenListBox1.ListIndex=0'如果没有选中项目，默认选中第一个项目
DimArr
Arr=Split（ListBox1.Value,vbTab）
WithTextBox1
.Visible=False
.TopLeftCell.Value=.Text
With.TopLeftCell.Offset（0,1）.Resize（1,UBound（Arr））
.Value=Arr
.Value=.Value
EndWith
.TopLeftCell.Offset（1,0）.Select
EndWith
EndIf
EndSub
登分结束后，可能会出现一些错误数据，如分数超科目满分、重复录入等，也可能出现录入分数而没录入学生信息或反之，还可能出现某几个学生没有录入的情况。
程序设计了查错代码进行检查并给出检查结果，同时在登分工作表末录入未登分的学生信息。
PublicSubChaCuo（）'查错
OnErrorResumeNext'设置容错语句，防止操作出错时卡住
Application.ScreenUpdating=False
Application.DisplayAlerts=False
'写入数组-----------
DimRAsLong'表格中行总数
DimLAsInteger'表格中列总数
DimArr'将表格写入数组
WithSheet2
With.UsedRange
R=.Rows.Count+.Row-1
L=.Columns.Count+.Column-1
EndWith
Arr=.Range（.Cells（1,1）,.Cells（R,L））.Value
.ProtectPassword:
="freeholiday52uys"'保护工作表
EndWith
'-----------------------------------
DimInBoxAsInteger
InBox=Application.InputBox（Prompt:
="请输入“"&Arr（1,1）&"”科满分：
",Title:
="请输入数字",Default:
=100,Type:
=1）
IfInBox=0Then
Application.ScreenUpdating=True
Application.DisplayAlerts=True
ExitSub
EndIf
'登分表写入数组-----------
DimSht3RAsLong'表格中行总数
DimSht3LAsInteger'表格中列总数
DimArrSht3'将表格写入数组
WithWorksheets（"登分"）
With.UsedRange
Sht3R=.Rows.Count+.Row-1
Sht3L=.Columns.Count+.Column-1
EndWith
ArrSht3=.Range（.Cells（1,1）,.Cells（Sht3R,Sht3L+1））.Value
EndWith
'-----------------------------------
'数据维护--------------------------
DimxAsLong,jAsLong,x1AsLong,iAsLong
DimStrAsString,StrKZAsString,StrKHAsString,StrCFAsString
DimflagAsBoolean
DimArr1（）AsLong'记录所有重复行号数组
DimArr2（）AsString'记录所有重复行号数组，用于写入sheet6
DimkAsLong'Arr1下标
DimmAsLong'Arr2下标
Str=""
StrKZ=""
StrKH=""
k=0
ReDimArr1（1To1）
m=1
ReDimArr2（1ToR,0）
Arr2（1,0）="重复学生信息维护结果：
"
Forx=2ToUBound（Arr,1）
'查登分错误********
IfIsNumeric（Arr（x,1））=FalseThen'字符
Str=Str&Cells（x,1）.Address（False,False）&","
ElseIfLen（Arr（x,1））=0Then'空值
IfLen（Arr（x,3））>0Then
StrKZ=StrKZ&Cells（x,1）.Address（False,False）&","
EndIf
Else'数字
SelectCaseVal（Arr（x,1））
CaseIs=-1,Is=-2,0ToInBox
CaseElse
Str=Str&Cells（x,1）.Address（False,False）&","
EndSelect
EndIf
'******************
'学生信息************
IfArr（x,3）=""Then
IfLen（Arr（x,1））>0Then
StrKH=StrKH&x&","'空行
EndIf
Else
'重复行&&&&&&&&&&&
flag=True
Forj=1ToUBound（Arr1）
IfArr1（j）=xThen'判断行x是否已查找过
flag=False
ExitFor'若Arr1数组存在x行则退出循环
EndIf
Nextj
IfflagThen'x没查找过则
StrCF=""
i=0
Forx1=x+1ToR
IfArr（x,3）=Arr（x1,3）AndArr（x,1）<>Arr（x1,1）Then
k=k+1
ReDimPreserveArr1（1Tok）
Arr1（k）=x1
StrCF=StrCF&x1&","
i=i+1
ExitFor'退出循环
EndIf
Nextx1
IfStrCF<>""Then'记录查找到的行
m=m+1
Ifi>100Then
Arr2（m,0）="与第"&x&"行信息重复的行>100行"
Else
Arr2（m,0）="与第"&x&"行信息重复的行：
"&StrCF
EndIf
EndIf
EndIf
'&&&&&&&&&&&&&&&&&
'记录已登成绩的学生信息&&&&&&&&&&&&
ArrSht3（Val（Arr（x,3））,Sht3L+1）="TRUE"
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
EndIf
'***************************
Nextx
'----------------------------------------
'记录未登成绩学生信息--------------------
DimArr3（）AsString
j=0
ReDimArr3（1ToSht3L+1,1To1）
Forx=2ToUBound（ArrSht3,1）
IfArrSht3（x,Sht3L+1）<>"TRUE"Then
j=j+1
ReDimPreserveArr3（1ToSht3L+1,1Toj）
Arr3（1,j）=x
Forx1=2ToSht3L+1
Arr3（x1,j）=ArrSht3（x,x1-1）
Next
EndIf
Nextx
'----------------------------------------
'未登成绩学生信息写入登分表------------
WithWorksheets（"登分"）
.Cells（R+1,3）.Resize（UBound（Arr3,2）,UBound（Arr3,1））.Value=Application.Transpose（Arr3）
.Range（"A2:
B"&R+j）.Locked=False
EndWith
'-------------------------------
'错误数据写入sheet6--------------------------
DimLastRowAsLong
WithSheet6'错误数据表
.Visible=xlSheetVisible'显示工作表
.UsedRange.Clear
.Cells（1,1）.Value="数据维护结果：
"&Now（）
.Cells（2,1）.Value="分值错误的单元格：
"&Str
.Cells（3,1）.Value="分值为空的单元格：
"&StrKZ
.Cells（5,1）.Value="学生信息为空的行：
"&StrKH
.Cells（7,1）.Resize（UBound（Arr2）,1）.Value=Arr2'学生信息重复行
Application.Goto.Cells（1,1）,True'将窗口滚动至该单元格，即该单元格位于当前窗口的左上方
.Activate
EndWith
MsgBox"数据维护完毕，请查看结果！
漏登成绩的学生信息已写入《"&Sheet2.Name&"》的第"&R&"行至"&R+j&"行！
",vbInformation,"提示信息…"
Application.ScreenUpdating=True
Application.DisplayAlerts=True
EndSub
参考文献：
罗刚君，EXCEL2010VBA编程与实践北京：
电子工业出版社，2010.12
升级会员 