巧用Excel VBA进行考试成绩登分录入

2016-05-17 12:44阅读：

http://blog.sina.cn/dpool/blog/u/1623808782

本程序下载下址
http://wenku.baidu.com/view/dbe60ce7482fb4daa48d4b85.html

登分是每次考试后不可少的工作，21世纪各种考试的成绩统计已经进入电脑时代，但登分工作却大多停留于“刀耕火种”年代——预先整理试卷、按座位号登分，重复数据手工查找……。笔者所在学校甚至还在使用最原始方法——评卷、拆卷、分班、登分。班级多，人数多，时间紧，不仅使得工作人员疲倦不堪，同时也出现不少的错误数据。鉴于此，笔者根据本校实际情况，用Excel VBA编了个程序，免去了按学号顺序登分之苦，也免去了登分前整理试卷之累，甚至避免了按记分册登分的查找不便之处，让教师可左手翻试卷，右手敲键盘登分，一气呵成。
程序需建立花名册（如图1）及登分（如图2）两个工作表，工作人员先在花名册工作表录入考生信息，如学号（或考号）、姓名、班级等，然后在登分工作表的第一列输入分数、第二列输入考生信息进行模糊查找，查找结果通过列表显示，你只需轻按键盘（Up、Down、Left、Right、Enter、Esc键）选择正确的学生信息即可快速录入。

巧用Excel <wbr>VBA进行考试成绩登分录入

图1

巧用Excel <wbr>VBA进行考试成绩登分录入

图2
程序代码简单，先在登分工作表新建两个 ActiveX 控件——文本框TextBox1和列表框ListBox1，然后为他们添加相关事件代码。
我们在工作表第二列激活的单元格里输入查询的关键字其实是一种错觉，实际上是用一个与单元格一模一样的文本框覆盖着单元格，其实输入到的是文本框内，为使文本框及列表框能随单元格的选择而相应改变，必须为工作表添加单元格激活事件代码：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next '设置容错语句，防止操作出错时卡住
Application.EnableEvents = False '禁用事件
If ListBox1.Visible Then ListBox1.Visible = False
If TextBox1.Visible Then TextBox1.Visible = False
ListBox1.Clear '清除列表
With Target '激活的单元格
If .Column = 2 And .Row <> 1 Then '属于第二列，并且不是第一行
'设置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 - 5 Then
ListBox1.Top = .Top - ListBox1.Height
Else
ListBox1.Height = .Height * 5
ListBox1.Top = .Top + .Height + 1
End If
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
Call TextBox1_Change

TextBox1.SelStart = 0
TextBox1.SelLength = 1000
End If
End With
Application.EnableEvents = True
End Sub
为了能随着输入查询关键字不断的进行模糊查找，需为TextBox1添加Change事件，并用Find方法实现查找功能。代码如下：
Private Sub TextBox1_Change()
Dim firstAddress As String, rng As Range, Arr() As String '声明需要用到的变量
TextBox1.Visible = True
ListBox1.Visible = True
ListBox1.Clear
TextBox1.TopLeftCell.Value = TextBox1.Text '激活的单元格内容与文本框一致
If TextBox1 = '' Then Exit Sub

K=-1
With Worksheets ('花名册').UsedRange
L = .Columns.Count + .Column – 1 '总列数

'按值模糊查找
Set rng = .Find(TextBox1.Text, LookIn:=xlValues, Lookat:=xlPart)
If Not rng Is Nothing Then '如果找到目标
firstAddress = rng.Address '记录第一个找到单元格的地址
Do '继续查找，直到找到的单元格地址等于刚才记录的单元格地址时停止
k=k+1
Redim Preserve Arr(k) '重新定义数组

'查找结果读入数组
Arr(k)= .Cells(rng.Row, 1)
For i = 2 To L
Arr(k)= Arr(k) & vbTab & .Cells(rng.Row, i)
Next

Set rng = .FindNext(rng) '查找下一个
Loop While rng.Address <> firstAddress

ListBox1.List = Arr '查找结果写入列表框
End If
End With
End Sub
为使文本框及列表框能响应Up、Down、Left、Right、Enter、Esc键，需为TextBox1和ListBox1添加KeyDown事件代码。
Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next '设置容错语句，防止操作出错时卡住
Select Case KeyCode
Case 13 '回车Enter键
If ListBox1.ListCount > 0 Then
If ListBox1.Text = '' Then ListBox1.ListIndex = 0 '如果没有选中项目，默认选中第一个项目
Dim Arr
Arr = Split(ListBox1.Value, vbTab) '将选中的项目文本转换为数组
With TextBox1
.Visible = False
.TopLeftCell.Value = .Text '当前单元格内容为文本框内容

'将选中项目内容写入工作表
With .TopLeftCell.Offset(0, 1).Resize(1, UBound(Arr))
.Value = Arr
.Value = .Value
End With

.TopLeftCell.Offset(1, 0).Select '激活当前单元格的向下的一个单元格
End With
KeyCode = 0
End If
Case 37 'Left向左键
TextBox1.Activate '激活文本框以输入查询关键字
Case 27 'Esc取消
TextBox1.Visible = False
ListBox1.Visible = False
End Select
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
Dim Arr
With TextBox1
Select Case KeyCode
Case 38 'UP向上键

举报/Report

我的更多文章

下载客户端阅读体验更佳