效果图:
1. 进入开发工具模式
因为之前没用过excel开发，找excel如何添加控件浪费了些时间。
2.添加2个ActiveX控件：textbox和listbox
如图
3.进入vba代码模式
快捷键Alt+F11
4.代码（具体代码不解释了，比较容易理解）
考虑到各种快捷键的方便性，大家可以继续添加功能来简易操作
'模块1
Public Function LChin(Str As String) As Variant
On Error Resume Next
Str = StrConv(Str, vbNarrow)
If Asc(Str) > 0 Or Err.Number = 1004 Then LChin = ""
LChin = WorksheetFunction.VLookup(Str, [{"吖","a";"八","b";"嚓","c";"咑","d";"鵽","e";"发","f";"猤","g";
"铪","h";"夻","j";"咔","k";"垃","l";"嘸","m";"旀","n";"噢","o";"妑","p";"七","q";"囕","r";"仨","s";"他","t";"屲","w";"夕","x";"丫","y";"帀","z"}], 2) End Function
'录入表
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim r1
ActiveCell.Value = ListBox1.Value
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
If col = 2 Then
Set r1 = Sheet8.Range("a:a").Find(ActiveCell.Value, , , xlWhole)
ActiveCell.Offset(0, 7) = Sheet8.Cells(r1.Row, 0).Value
ElseIf col > 2 And col < 6 Then
Set r1 = Sheet8.Range("c:c").Find(ActiveCell.Value, , , xlWhole)
ActiveCell.Offset(0, 7) = Sheet8.Cells(r1.Row, 2).Value
ElseIf col > 5 And col < 8 Then
Set r1 = Sheet8.Range("e:e").Find(ActiveCell.Value, , , xlWhole)
ActiveCell.Offset(0, 7) = Sheet8.Cells(r1.Row, 4).Value
ElseIf col > 7 And col < 18 Then
Set r1 = Sheet8.Range("g:g").Find(ActiveCell.Value, , , xlWhole)
ActiveCell.Offset(0, 7) = Sheet8.Cells(r1.Row, 6).Value
ElseIf col > 17 And col < 21 Then
Set r1 = Sheet8.Range("i:i").Find(ActiveCell.Value, , , xlWhole)
ActiveCell.Offset(0, 7) = Sheet8.Cells(r1.Row, 8).Value
End If
End Sub
Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then
ActiveCell.Value = ListBox1.Value
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End If
If KeyCode = vbKeyLeft Then
Sheet3.TextBox1.Activate
End If
End Sub
Private Sub ListBox1_GotFocus()
On Error Resume Next
ListBox1.ListIndex = 0
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Or KeyCode = vbKeyUp Or KeyCode = vbKeyDown Or KeyCode = vbKeyRight Then
Sheet3.ListBox1.Activate
End If
If KeyCode = vbKeyDelete Then
ActiveCell.Value = ""
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End If
If KeyCode = vbKeyEscape Then
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End If
End Sub
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim i As Integer
Dim Language As Boolean
Dim myStr As String, strText$, n1&
Me.ListBox1.Clear
With Me.TextBox1
For i = 1 To Len(.Value)
If Asc(Mid$(.Value, i, 1)) > 255 Or Asc(Mid$(.Value, i, 1)) < 0 Then
Language = True
myStr = myStr & Mid$(.Value, i, 1)
Else
myStr = myStr & LCase(Mid$(.Value, i, 1))
End If
Next
End With
With Sheet8
If col = 2 Then
For i = 2 To .Range("A65536").End(xlUp).Row
If Language = True Then
n1 = InStr(.Cells(i, 1), myStr)
If n1 > 0 Then
Me.ListBox1.AddItem .Cells(i, 1).Value
End If
Else
n1 = InStr(.Cells(i, 2), myStr)
If n1 > 0 Then
Me.ListBox1.AddItem .Cells(i, 1).Value
End If
End If
Next
ElseIf col > 2 And col < 6 Then
For i = 2 To .Range("C65536").End(xlUp).Row
If Language = True Then
n1 = InStr(.Cells(i, 3), myStr)
If n1 > 0 Then
Me.ListBox1.AddItem .Cells(i, 3).Value
End If
Else
n1 = InStr(.Cells(i, 4), myStr)
If n1 > 0 Then
Me.ListBox1.AddItem .Cells(i, 3).Value
End If
End If
Next
ElseIf col > 5 And col < 8 Then
For i = 2 To .Range("E65536").End(xlUp).Row
If Language = True Then
n1 = InStr(.Cells(i, 5), myStr)
If n1 > 0 Then
Me.ListBox1.AddItem .Cells(i, 3).Value
End If
Else
n1 = InStr(.Cells(i, 6), myStr)
If n1 > 0 Then
Me.ListBox1.AddItem .Cells(i, 3).Value
End If
End If
Next
ElseIf col > 7 And col < 18 Then
For i = 2 To .Range("G65536").End(xlUp).Row
If Language = True Then
n1 = InStr(.Cells(i, 7), myStr)
If n1 > 0 Then
Me.ListBox1.AddItem .Cells(i, 3).Value
End If
Else
n1 = InStr(.Cells(i, 8), myStr)
If n1 > 0 Then
Me.ListBox1.AddItem .Cells(i, 3).Value
End If
End If
Next
ElseIf col > 17 And col < 21 Then
For i = 2 To .Range("I65536").End(xlUp).Row
If Language = True Then
n1 = InStr(.Cells(i, 9), myStr)
If n1 > 0 Then
Me.ListBox1.AddItem .Cells(i, 3).Value
End If
Else
n1 = InStr(.Cells(i, 10), myStr)
If n1 > 0 Then
Me.ListBox1.AddItem .Cells(i, 3).Value
End If
End If
Next
End If
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer
If Target.Count > 1 Then Exit Sub
If Target.Row < 2 Then Exit Sub
If Target.Column < 2 Or Target.Column > 22 Then Exit Sub
Me.ListBox1.Clear
col = Target.Column
With Me.TextBox1
.Visible = True
.Top = Target.Top
.Left = Target.Left
.Width = Target.Width
.Height = Target.Height
.Activate
End With
With Me.ListBox1
.Visible = True
.Top = Target.Top
.Left = Target.Left + Target.Width
.Width = Target.Width
.Height = Target.Height * 5
End With
'============================================================================
'
' 根据点击的文本框,智能显示相应的listbox
' 对应关系:
' Column = 2 ----------> 地区 cells=1
' Column =3-5 ---------> 餐饮 cells=3
' Column =6-7 ---------> 住宿 cells=5
' Column =8-17 --------> 景点 cells=7
' Column =18-20 -------> 购物点 cells=9
'
'============================================================================
If Target.Column = 2 Then
With Me.ListBox1
For i = 2 To Sheet8.Range("A65536").End(xlUp).Row
.AddItem Sheet8.Cells(i, 1).Value
Next
End With
ElseIf Target.Column > 2 And Target.Column < 6 Then
With Me.ListBox1
For i = 2 To Sheet8.Range("C65536").End(xlUp).Row
.AddItem Sheet8.Cells(i, 3).Value
Next
End With
ElseIf Target.Column > 5 And Target.Column < 8 Then
With Me.ListBox1
For i = 2 To Sheet8.Range("E65536").End(xlUp).Row
.AddItem Sheet8.Cells(i, 5).Value
Next
End With
ElseIf Target.Column > 7 And Target.Column < 18 Then
With Me.ListBox1
For i = 2 To Sheet8.Range("G65536").End(xlUp).Row
.AddItem Sheet8.Cells(i, 7).Value
Next
End With
ElseIf Target.Column > 17 And Target.Column < 21 Then
With Me.ListBox1
For i = 2 To Sheet8.Range("I65536").End(xlUp).Row
.AddItem Sheet8.Cells(i, 9).Value
Next
End With
Else
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End If
End Sub
'数据表
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Dim myStr As String
With Target
If .Column <> 5 Or .Count > 1 Then Exit Sub
If WorksheetFunction.CountIf(Sheet3.Range("A:A"), .Value) > 1 Then
.Value = ""
MsgBox "不能输入重复的企业名称!", 64
Exit Sub
End If
For i = 1 To Len(.Value)
If Asc(Mid$(.Value, i, 1)) > 255 Or Asc(Mid$(.Value, i, 1)) < 0 Then
myStr = myStr & LChin(Mid$(.Value, i, 1))
Else
myStr = myStr & LCase(Mid$(.Value, i, 1))
End If
Next
.Offset(, 1).Value = myStr
End With
End Sub
