求助：输入逐步提示信息VBA编程指教
输入逐步提示信息VBA编程请教
我的编程以下，其中有错误，但不知道如何修改，请各位大师帮忙，谢谢。
（注：本编程效果：在录入表只要输入一个汉字或字母就会出现一个提示框，从提示框中可以选择所要输入数据表中内容。）
1、模块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";"日","R";"撒","S";"他","T";"哇","W";"呀","Y";"砸","Z"}])
End Function
2、sheet1(录入表）
Option Explicit
Private Sub listbox1_dblclick(ByVal cancel As msforms.returninteger, ByVal shift As Integer)
ActiveCell.Value = listbox1.Value
Me.listbox1.Clear
Me.textbox1 = ""
Me.listbox1.Visible = False
Me.textbox1.Visible = False
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
Me.listbox1.Clear
With Me.textbox1
For i = 1 To ten(Value)
If Asc(Mid$(.Value, i, 1)) > 255 Or Asc(Mid$(.Value, i, 1)) < 0 Then
language = ture
mystr = mystr & Mid$(Value, i, 1)
Else
mystr = mystr & lcale(Mid$(Value, i, 1))
End If
Next
End With
With Sheet2
For i = 2 To .Range("a65536").End(xlUp).Row
If language = ture Then
If Left(Cells(i, 1).Value, Len(mystr)) = mystr Then
Me.listbox1.AddItem .Cells(i, 1).Value
End If
Else
If Left(Cells(i, 2), Value, Len(mystr)) = mysty Then
Me.listbox1 .AddItem.Cells(i, 1).Value
End If
End If
Next
End With
End Sub
Private Sub worksheet_selectionchange(ByVal target As Range)
Dim i As Integer
If target.colunt = 1 Then
If target.Column = 1 And targe.Row > 1 Then
With Me.textbox1
.Visible = True
.Top = target.Top
.Left = target.Left
.Width = target.Width
.Height = target.Height
End With
With Me.listbox1
.Clear
.Visible = True
.Top = target.Top
.Left = target.Left + target.Width
.Width = target.Width
.Height = target.Height * 5
For i = 2 To Sheet2.Range("a65536").End(xlUp).Row
.AddItem Sheet2.Cells(i, 1).Value
Next
End With
Else
Me.listbox1.Clear
Me.textbox1 = ""
Me.listbox1.Visible = False
Me.textbox1.visile = False
End If
End If
End Sub
End Sub
3、sheet2(数据表）
Option Explicit
Private Sub worksheet_change(ByVal target As Range)
Dim i As Integer
Dim mystr As String
With target
If .Column <> 1 Or .Count > 1 Then Exit Sub
If .WorksheetFunction.CountIf(Sheet2.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
[解决办法]
你的代码是太多错误了～例如在with里的value没有“.”，函数名错误……我帮你改了一下，能跑起来了。
模块一没问题；
sheet1表：
Option Explicit
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ActiveCell.Value = ListBox1.Value
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
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
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 Sheet2
For i = 2 To .Range("a65536").End(xlUp).Row
If language = True Then
If Left(Cells(i, 1).Value, Len(mystr)) = mystr Then
Me.ListBox1.AddItem .Cells(i, 1).Value
End If
Else
If Left(Cells(i, 2).Value, Len(mystr)) = mystr Then
Me.ListBox1.AddItem .Cells(i, 1).Value
End If
End If
Next
End With
End Sub
Private Sub worksheet_selectionchange(ByVal target As Range)
Dim i As Integer
If target.Column = 1 Then
If target.Column = 1 And target.Row > 1 Then
With Me.TextBox1
.Visible = True
.Top = target.Top
.Left = target.Left
.Width = target.Width
.Height = target.Height
End With
With Me.ListBox1
.Clear
.Visible = True
.Top = target.Top
.Left = target.Left + target.Width
.Width = target.Width
.Height = target.Height * 5
For i = 2 To Sheet2.Range("a65536").End(xlUp).Row
.AddItem Sheet2.Cells(i, 1).Value
Next
End With
Else
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.visile = False
End If
End If
End Sub
sheet2表：
Option Explicit
Private Sub worksheet_change(ByVal target As Range)
Dim i As Integer
Dim mystr As String
With target
If .Column <> 1 Or .Count > 1 Then Exit Sub
If .WorksheetFunction.CountIf(Sheet2.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
[解决办法]
不好意思，这里还有个错误没改过来，在sheet1表中：
……
Private Sub worksheet_selectionchange(ByVal target As Range)
Dim i As Integer
If target.Column = 1 Then
If target.Column = 1 And target.Row > 1 Then
With Me.TextBox1
.Visible = True
.Top = target.Top
.Left = target.Left
.Width = target.Width
.Height = target.Height
End With
With Me.ListBox1
.Clear
.Visible = True
.Top = target.Top
.Left = target.Left + target.Width
.Width = target.Width
.Height = target.Height * 5
For i = 2 To Sheet2.Range("a65536").End(xlUp).Row
.AddItem Sheet2.Cells(i, 1).Value
Next
End With
Else
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End If
End If
End Sub
[解决办法]
“编译错误，用户定义类型未定义。”红色错误提示在哪一行啊？
你点击空白行出错，也许你也要处理一下你点击在其他的地方的程序啊。
If target.Column = 1 And target.Row > 1 Then
这个点击第一行，第一列。会不会太死了呢。
[解决办法]
我重新做了一下你的功能，不知道是否合用，你把代码贴到sheet1中，代码如下：
1、在工作表sheet1上放置一个listbox和一个textbox，设置它们的Visiable属性为False。
2、在sheet2的A列上输入一些人名，例如： 张三、张三丰、小明、小李飞刀……最好是有同姓的
3、用VBA控制，当活动单元格为sheet1 A列中的单元格时，listbox和textbox的visiable属性都设为True，并且设置他们的left、top、width、height属性
4、将sheet2表中A列上所有的值填到listbox中
到这里这个功能就已经基本实现了，剩下的工作就是做得更人性化一些，更好用一些，所有代码如下：
（Sheet1表）
Private Sub infoList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If Me.infoList.listCount > 0 Then
Selection = Me.infoList.Value
End If
'**将活动单元格切换到同列的下一个
Sheet1.Cells(Selection.Row + 1, Selection.Column).Select
End Sub
Private Sub txtContext_Change()
Dim arrList() As String
If Me.infoList.listCount > 0 Then
ReDim arrList(Me.infoList.listCount - 1)
Else
Exit Sub
End If
j% = 0
For i% = 0 To UBound(arrList)
If Me.txtContext.Text = Mid(Me.infoList.List(i), 1, Len(Me.txtContext.Text)) Then
arrList(j%) = Me.infoList.List(i%)
j% = j% + 1
End If
Next
If arrList(0) <> "" Then
'**若有符合条件的内容则，列表框清空后重新填入符合条件的内容
Me.infoList.Clear
For i% = 0 To UBound(arrList)
If arrList(i%) <> "" Then
Me.infoList.AddItem arrList(i%)
End If
Next
End If
End Sub
Private Sub txtContext_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'**判断是否按下回车
If KeyCode = 13 Then
'**将文本框的内容填入当前活动单元格
Selection = Me.txtContext.Text
'**将活动单元格切换到同列的下一个
Sheet1.Cells(Selection.Row + 1, Selection.Column).Select
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'**判断用户是否选中第一列，只有当前活动单元格为第一列中的单元格时才显示列表
If Target.Column = 1 Then
'**设置textBox
With Me.txtContext
.Text = "" '**清空内容
.Top = Target.Top '**顶端定位到当前活动单元格顶端
.Left = Target.Left '**左边定位到当前活动单元格左边
.Width = Target.Width '**设定文本框宽为当前活动单元格的宽
.Height = Target.Height '**设定文本框高为当前活动单元格的高
.Visible = True '**显示文本框
End With
'**设置listbox
With Me.infoList
.Top = Target.Top '**顶端定位到当前活动单元格顶端
.Left = Target.Width '**左边定位到当前活动单元格右边
.Width = Target.Width '**设定列表宽为当前活动单元格的宽
.Height = 100 '**设定列表框高位100
.Clear '**清空列表内容
'**将sheet2表A列所有值填入列表框中
With Sheet2
For i% = 1 To .Range("a65536").End(xlUp).Row
Me.infoList.AddItem .Cells(i, 1)
Next
End With
.Visible = True '**显示列表
End With
Else
Me.txtContext.Visible = False
Me.infoList.Visible = False
End If
End Sub
[解决办法]
还有什么问题发我邮箱吧，有时间我帮你看看
56411000@qq.com
[解决办法]
上面的代码忘记说明了，你在sheet1中方Textbox的时候改名为txtContext，放listbox的时候改名为infoList，不然会提示找不到对象（有点罗嗦了）
