'输入姓名的主体函数
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