本程序下载下址

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