'输入姓名的主体函数

Sub 姓名输入(aim As Range)

'清除单元格中的空格并将输入的字母转换为小写

On Error

Resume Next

Dim short

As String

short =

Trim(LCase(aim.Value))

'声明动态数组，调用Search过程在姓名对照表中查找信息

Dim

result() As String

Search

short, result

'如果查找到一个结果则直接写入单元格

If

UBound(result) = 1 Then

aim.Value =

result(1)

'如果没有查找到则直接退出程序

ElseIf

UBound(result) = 0 Then

Exit Sub

'如果查找到两个以上的结果则等待用户选择

Else

'循环等待用户输入，直至输入正确

Dim goOn As

Boolean

Do

goOn = GetOne(result,

aim)

Loop Until (goOn =

True)

End

If

End Sub

'在姓名对照表中查找对应信息存储在result()数组中

Sub Search(short As String, result() As

String)

'如果出错则弹出警告框

On Error

GoTo notable

Dim

searchTable As Worksheet

Set

searchTable = Worksheets("姓名对照")

'获取该工作表的总人数

Dim

rowNum As Integer

rowNum =

searchTable.Cells(1, 1).CurrentRegion.Rows.Count

'重新分配可变数组

ReDim

Preserve result(0) As String

'声明循环变量

Dim row,

index As Integer

index =

1

'循环查找工作表的每一行

For row =

1 To rowNum

Dim aim

As String

aim =

searchTable.Cells(row, 1)

'如果内容符合缩写

If aim =

short Then

'重新分配数组长度

ReDim

Preserve result(index) As String

'将结果存入数组的新空间

result(index) = CStr(searchTable.Cells(row, 2))

index = index + 1

End If

Next

row

Exit

Sub

'姓名对照表不存在时的警告消息

notable:

MsgBox

("找不到姓名对照表！")

End Sub

'有一个以上查找结果时让用户选择其一的函数

Function GetOne(result() As String, aim As

Range) As Boolean

'将所有查找结果及其序号拼接为提示字符串

Dim

warning As String

warning =

"请输入数字选择一个姓名" + Chr(10)

Dim index

As Integer

For index

= 1 To UBound(result)

warning = warning +

CStr(index) + ":" + result(index)  + "

"

Next

index

'接受用户输入

Dim

answer As String

answer =

InputBox(warning)

If answer

= "" Then

GetOne =

True

Exit

Function

End

If

'判断其是否为数字，以及大小是否符合范围

answer =

Trim(answer)

GetOne =

False

On Error

GoTo msg

index =

CInt(answer)

If index

>= 1 And index <= UBound(result)

Then

GetOne =

True

End

If

'如果输入有效则在单元格中写入内容。否则重新输入

If GetOne

= True Then

aim.Value =

result(index)

Else

msg:

MsgBox

("输入内容格式错误或超出范围，请重新输入")

End

If

End Function