关键词检索程序，如何实现清空文本框内容时，列表框不检索内容

winteryi

小白一个，借用论坛前辈的程序，制作了一个模糊检索，基本满足需求。但是有个问题：在文本框录入错误，删除全部关键词时，程序将所有数据源检索出来显示在列表框，由于数据源较多，造成检索过程很长，excel卡死。请教各位大神，如何完善代码，以实现：删除全部关键词时，程序不执行检索？
程序代码如下：

1. Private Sub ListBox1_Click()
   
2.     ActiveCell = ListBox1.Value
   
3.     ActiveCell.Offset(0, 1).Select
   
4. End Sub
   
5. 
   
6. 
   
7. 
   
8. Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
   
9. Dim Arr1, myStr$, i&
   
10.     With Me.TextBox1
    
11.            For i = 1 To Len(.Value)
    
12.                  If Asc(Mid$(.Value, i, 1)) > 255 Or Asc(Mid$(.Value, i, 1)) < 0 Then
    
13.                     Language = True
    
14.                     myStr = myStr & Mid$(.Value, i, 1)
    
15.                  Else
    
16.                     myStr = myStr & UCase(Mid$(.Value, i, 1))
    
17.                  End If
    
18.           Next
    
19.     End With
    
20.     With Sheet5
    
21.            Me.ListBox1.Clear
    
22.                  Arr1 = .Range("a1:a" & .Range("a65535").End(xlUp).Row)
    
23.                  For i = 1 To UBound(Arr1)
    
24.                       If InStr(Arr1(i, 1), myStr) Then
    
25.                              Me.ListBox1.AddItem Arr1(i, 1)
    
26.                       End If
    
27.                  Next i
    
28.     End With
    
29. 
    
30. End Sub
    
31. <hr class="l">Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
32.     If Target.Column <> 3 Or Target.Count > 2 Then
    
33.         ListBox1.Visible = False
    
34.         TextBox1.Visible = False
    
35.         Exit Sub
    
36.     End If
    
37. 
    
38.     With TextBox1
    
39.         .Activate
    
40.         .Visible = True
    
41.         .Value = ""
    
42.         .Top = Target.Top
    
43.         .Left = Target.Left
    
44.         .Width = 500
    
45.         .Height = Target.Height + 5
    
46.     End With
    
47. 
    
48.     With ListBox1
    
49.         .Visible = True
    
50.         .Top = Target.Offset(0, 1).Top
    
51.         .Left = Target.Offset(0, 1).Left
    
52.         .Width = 500
    
53.         .Height = Target.Height * 10
    
54.         .Clear
    
55.     End With
    
56. End Sub
    
57. 
    

复制代码

蓝桥玄霜

在第9句代码下增加：
If keycode<>13 then Exit Sub
试试看

winteryi

蓝桥玄霜 发表于 2023-5-18 11:17
在第9句代码下增加：
If keycode13 then Exit Sub
试试看

感谢指导，添加该行代码后，列表栏不执行检索了，可否再帮忙分析，感谢！

winteryi

已通过另一思路解决哈，如有其他方法，感谢不吝分享。目前解决代码如下：

1. [code]'设置文本框和列表框的大小及位置
   
2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
3.     Dim b As Boolean, arr
   
4.     If Target.Column <> 3 Or Target.Row < 2 Then b = True '如果用户选择的单元格不是第1列或者属于第1行
   
5.     If Target.Columns.Count > 1 Or Target.Rows.Count > 1 Then b = True '如果用户选择的单元格数量大于1
   
6.     If b Then
   
7.         ListBox1.Visible = False '不可见
   
8.         TextBox1.Visible = False '不可见
   
9.         Exit Sub '退出程序
   
10.     End If
    
11.     With Worksheets("数据源表") '下拉列表来源内容的所在工作表
    
12.         arr = .Range("a1:a" & .Cells(Rows.Count, "a").End(3).Row) '数据源
    
13.     End With
    
14.     With TextBox1
    
15.         .Value = ""
    
16.         .Visible = True '可见
    
17.         .Top = Target.Top '文本框顶部位置
    
18.         .Left = Target.Left '文本框左侧位置
    
19.         .Height = Target.Height + 5 '文本框高度
    
20.         .Width = Target.Width '文本框宽度
    
21.         .Activate '激活文本框
    
22.     End With
    
23.     With ListBox1
    
24.         .Visible = True '可
    
25.         .Top = Target.Offset(-2, 1).Top
    
26.         .Left = Target.Offset(0, 1).Left
    
27.         .Height = Target.Height * 15
    
28.         .Width = Target.Width
    
29.         .List = arr '写入数据源数据
    
30.     End With
    
31. End Sub
    
32. 
    
33. 
    
34. '根据文本框的输入值动态匹配数据
    
35. Private Sub TextBox1_Change()
    
36.     Dim arr, brr, i&, k&
    
37.     With Worksheets("数据源表") '下拉列表来源内容的所在工作表
    
38.         arr = .Range("a1:a" & .Cells(Rows.Count, "a").End(3).Row) '数据源
    
39.     End With
    
40.     If TextBox1.Text = "" Then ListBox1.List = arr: Exit Sub
    
41.     ReDim brr(1 To UBound(arr))
    
42.     For i = 1 To UBound(arr)
    
43.         If InStr(1, arr(i, 1), TextBox1.Text, vbTextCompare) Then  '忽略字母大小写
    
44.             k = k + 1
    
45.             brr(k) = arr(i, 1)
    
46.         End If
    
47.     Next
    
48.     ListBox1.List = brr '写入匹配后的数据
    
49. End Sub
    
50. 
    
51. 
    
52. '如果双击列表框的内容则写入活动单元格
    
53. Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    
54.     ActiveCell = ListBox1.Text
    
55.     With ListBox1
    
56.         .Clear '清空列表框
    
57.         .Visible = False
    
58.     End With
    
59.     With TextBox1
    
60.         .Value = ""
    
61.         .Visible = False
    
62.     End With
    
63. End Sub
    

复制代码

[/code]

tanglf188

第九行插入
Application.ScreenUpdating = False
Application.EnableEvents = False
第29行插入
Application.ScreenUpdating = True
Application.EnableEvents = True