本程序下载下址
http://wenku.baidu.com/view/dbe60ce7482fb4daa48d4b85.html
登分是每次考试后不可少的工作，21世纪各种考试的成绩统计已经进入电脑时代，但登分工作却大多停留于“刀耕火种”年代——预先整理试卷、按座位号登分，重复数据手工查找……。笔者所在学校甚至还在使用最原始方法——评卷、拆卷、分班、登分。班级多，人数多，时间紧，不仅使得工作人员疲倦不堪，同时也出现不少的错误数据。鉴于此，笔者根据本校实际情况，用Excel
VBA编了个程序，免去了按学号顺序登分之苦，也免去了登分前整理试卷之累，甚至避免了按记分册登分的查找不便之处，让教师可左手翻试卷，右手敲键盘登分，一气呵成。
程序需建立花名册（如图1）及登分（如图2）两个工作表，工作人员先在花名册工作表录入考生信息，如学号（或考号）、姓名、班级等，然后在登分工作表的第一列输入分数、第二列输入考生信息进行模糊查找，查找结果通过列表显示，你只需轻按键盘（Up、Down、Left、Right、Enter、Esc键）选择正确的学生信息即可快速录入。
图1
图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向上键
'激活当前单元格的上一单元格
.Visible = False
.TopLeftCell.Value = .Text
.TopLeftCell.Offset(-1, 0).Select
KeyCode = 0
Case 13 'Enter回车
'输入列表框第一个项目内容至工作表并激活当前单元格的下一单元格
If ListBox1.ListCount > 0
Then
Arr = Split(ListBox1.List(0), vbTab)
.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
KeyCode = 0
End If
Case 40 'Down向下键
'激活当前单元格的下一单元格
.Visible = False
.TopLeftCell.Value = .Text
.TopLeftCell.Offset(1, 0).Select
KeyCode = 0
Case 37 'Left向左键
'输入列表框第一个项目内容至工作表并激活当前单元格的左一单元格
.Visible = False
If ListBox1.ListCount > 0 Then
Arr = Split(ListBox1.List(0), vbTab)
.TopLeftCell.Value = .Text
With .TopLeftCell.Offset(0, 1).Resize(1, UBound(Arr))
.Value = Arr
.Value
= .Value
End With
End If
.TopLeftCell.Offset(0, -1).Select
KeyCode = 0
Case 39 'Right向右键
ListBox1.Activate '激活列表框
Case 27 'Esc取消
.Visible = False
ListBox1.Visible = False
Selection.Select
End
Select
End With
End Sub
为了能用鼠标双击点选项目实现输入，效果等同按下Enter键，需为ListBox1添加DblClick事件代码。
Private Sub
ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume
Next
'设置容错语句，防止操作出错时卡住
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
End If
End Sub
登分结束后，可能会出现一些错误数据，如分数超科目满分、重复录入等，也可能出现录入分数而没录入学生信息或反之，还可能出现某几个学生没有录入的情况。程序设计了查错代码进行检查并给出检查结果，同时在登分工作表末录入未登分的学生信息。
Public Sub ChaCuo()
'查错
On Error Resume
Next
'设置容错语句，防止操作出错时卡住
Application.ScreenUpdating =
False
Application.DisplayAlerts =
False
'写入数组-----------
Dim R As Long
'表格中行总数
Dim L As
Integer '表格中列总数
Dim Arr '将表格写入数组
With Sheet2
With
.UsedRange
R = .Rows.Count + .Row - 1
L = .Columns.Count + .Column - 1
End
With
Arr
= .Range(.Cells(1, 1), .Cells(R, L)).Value
.Protect Password:="freeholiday52uys" '保护工作表
End With
'-----------------------------------
Dim InBox As Integer
InBox =
Application.InputBox(Prompt:="请输入“" & Arr(1, 1) &
"”科满分：", Title:="请输入数字", Default:=100,
Type:=1)
If InBox = 0 Then
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit
Sub
End If
'登分表写入数组-----------
Dim Sht3R As
Long '表格中行总数
Dim Sht3L As
Integer '表格中列总数
Dim ArrSht3
'将表格写入数组
With Worksheets
("登分")
With
.UsedRange
Sht3R = .Rows.Count + .Row - 1
Sht3L = .Columns.Count + .Column - 1
End
With
ArrSht3 = .Range(.Cells(1, 1), .Cells(Sht3R, Sht3L +
1)).Value
End With
'-----------------------------------
'数据维护--------------------------
Dim x As Long, j As Long, x1 As
Long, i As Long
Dim Str As String, StrKZ As
String, StrKH As String, StrCF As String
Dim flag As Boolean
Dim Arr1() As Long
'记录所有重复行号数组
Dim Arr2() As String
'记录所有重复行号数组，用于写入sheet6
Dim k As Long
'Arr1下标
Dim m As Long 'Arr2
下标
Str = ""
StrKZ = ""
StrKH = ""
k = 0
ReDim Arr1(1 To 1)
m = 1
ReDim Arr2(1 To R,
0)
Arr2(1, 0) =
"重复学生信息维护结果："
For x = 2 To UBound(Arr,
1)
'查登分错误********
If
IsNumeric(Arr(x, 1)) = False Then '字符
Str = Str & Cells(x, 1).Address(False, False) &
","
ElseIf Len(Arr(x, 1)) = 0 Then '空值
If Len(Arr(x, 3)) > 0 Then
StrKZ = StrKZ & Cells(x, 1).Address(False, False) &
","
End If
Else
'数字
Select Case Val(Arr(x, 1))
Case Is = -1, Is = -2, 0 To InBox
Case Else
Str = Str
& Cells(x, 1).Address(False, False) & ","
End Select
End
If
'******************
'学生信息************
If
Arr(x, 3) = "" Then
If Len(Arr(x, 1)) > 0 Then
StrKH = StrKH & x & "," '空行
End If
Else
'重复行&&&&&&&&&&&
flag = True
For j = 1 To UBound(Arr1)
If Arr1(j) = x Then '判断行x是否已查找过
flag = False
Exit For '若Arr1数组存在x行则退出循环
End If
Next j
If flag Then 'x没查找过则
StrCF = ""
i = 0
For x1 = x + 1 To R
If Arr(x, 3) = Arr(x1, 3) And Arr(x, 1) <> Arr(x1, 1)
Then
k = k + 1
ReDim Preserve Arr1(1 To k)
Arr1(k)
= x1
StrCF = StrCF & x1 & ","
i = i + 1
Exit For '退出循环
End If
Next x1
If StrCF <> "" Then '记录查找到的行
m = m + 1
If i > 100 Then
Arr2(m, 0) = "与第" & x & "行信息重复的行>100行"
Else
Arr2(m, 0) = "与第" & x & "行信息重复的行：" & StrCF
End If
End If
End If
'&&&&&&&&&&&&&&&&&
'记录已登成绩的学生信息&&&&&&&&&&&&
ArrSht3(Val(Arr(x, 3)), Sht3L + 1) = "TRUE"
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
End
If
'***************************
Next x
'----------------------------------------
'记录未登成绩学生信息--------------------
Dim Arr3() As String
j = 0
ReDim Arr3(1 To Sht3L + 1, 1 To
1)
For x = 2 To UBound(ArrSht3,
1)
If
ArrSht3(x, Sht3L + 1) <> "TRUE" Then
j = j + 1
ReDim Preserve Arr3(1 To Sht3L + 1, 1 To j)
Arr3(1, j) = x
For
x1 = 2 To Sht3L + 1
Arr3(x1, j) = ArrSht3(x, x1 - 1)
Next
End
If
Next x
'----------------------------------------
'未登成绩学生信息写入登分表------------
With Worksheets
("登分")
.Cells(R + 1, 3).Resize(UBound(Arr3, 2), UBound(Arr3, 1)).Value =
Application.Transpose(Arr3)
.Range("A2:B" & R + j).Locked = False
End With
'-------------------------------
'错误数据写入sheet6--------------------------
Dim LastRow As Long
With Sheet6
'错误数据表
.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
End With
MsgBox "数据维护完毕，请查看结果！漏登成绩的学生信息已写入《" & Sheet2.Name &
"》的第" & R & "行至" & R + j & "行！", vbInformation, "提示信息…"
Application.ScreenUpdating =
True
Application.DisplayAlerts =
True
End Sub
参考文献：
罗刚君，EXCEL 2010 VBA编程与实践 北京：电子工业出版社，2010.12
