VBA实现动态查询下拉列表输入 |
您所在的位置：网站首页 › 下拉列表式输入 › VBA实现动态查询下拉列表输入 |
VBA实现动态查询下拉列表输入
|
博主公众号：Romi的杂货铺，欢迎关注一起玩耍！ Excel利用VBA实现下拉列表，同时支持输入时动态查询，根据输入的不同实现动态的查询 先看一下实验效果：当点击website这一列时会出现所有的网站列表，双击可点击选择数值填入 输入关键字时会只出现包含关键字的结果
在C，D两列选择单元格后会出现仅在此网站下的数据如果网站为空则会自动向上寻找，同时也支持自定义的搜索
第一部分为工作表选取改变事件，实现的是当有单元格被选定时会自动出现下拉菜单和输入框。首先需要在sheet中创建一个listbox和textbox.在开发工具-插入-下拉框/文本框注意要选activex控件，不能选择上面的控件 具体代码及注释如下： '工作表选取改变事件 Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim i, x, rownu As Variant Dim d As Object Dim arr, arr_key, arr1, yun, arr_po Dim website_name As String Set d = CreateObject("scripting.dictionary") Me.ListBox1.Clear 'target为选取的单元格对象 tacolumn = Target.Column tarow = Target.Row '添加website部分 '选择触发的区域，使用Target.Cells.CountLarge是为了保证选择的是一个单元格而不是一片区域，同时区域过大不会报错 If Target.Column = 1 And Target.Row > 10 And Target.Cells.CountLarge = 1 Then With Me.TextBox1'textbox的大小，位置，和显示 .Visible = True .Top = Target.Top .Left = Target.Left .Width = Target.Width .Height = Target.Height .Activate End With With Me.ListBox1'listbox的大小，位置，和显示 .Visible = True .Top = Target.Top .Left = Target.Left + Target.Width .Width = 400 .Height = 300 '将需要写入的数据装入数组 arr = Sheets("format_information").Range("a2:a" & Sheets("format_information").Cells(Rows.Count, 1).End(xlUp).Row) For x = 1 To UBound(arr) d(arr(x, 1)) = "" Next '将值写入到listbox中 .List = d.keys() End With 'position和fomat部分.逻辑与上述代码一致 ElseIf (Target.Column = 3 Or Target.Column = 4) And Target.Row > 10 And Target.Cells.CountLarge = 1 Then website_name = Cells(Target.Row, 1).Value rownu = Target.Row - 1 Do Until website_name "" website_name = Cells(rownu, 1).Value rownu = rownu - 1 Loop 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 = 400 .Height = 300 yun = SQLtoArr("Select position_channel,Format FROM [format_information$] where Website like '%" & website_name & "%'") arr_po = Sheets("format_information").Range("AA1:AA" & Sheets("format_information").Cells(Rows.Count, 27).End(xlUp).Row) arr1 = Sheets("format_information").Range("AB1:AB" & Sheets("format_information").Cells(Rows.Count, 28).End(xlUp).Row) For x = 1 To UBound(arr_po) d(arr_po(x, 1) & "■" & arr1(x, 1)) = "" Next .List = d.keys() End With Else Me.ListBox1.Clear Me.TextBox1 = "" Me.ListBox1.Visible = False Me.TextBox1.Visible = False End If End Sub '利用SQL函数进行筛选和取值的函数 Function SQLtoArr(strSQL) Dim Conn As Object, Rst As Object Dim strConn As String Dim i As Integer, PathStr As String Set Conn = CreateObject("ADODB.Connection") Set Rst = CreateObject("ADODB.Recordset") PathStr = ThisWorkbook.FullName '设置工作簿的完整路径和名称 Select Case Application.Version * 1 '设置连接字符串,根据版本创建连接 Case Is = 12 strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";""" End Select Conn.Open strConn '打开数据库链接 Set Rst = Conn.Execute(strSQL) '执行查询，并将结果输出到记录集对象 Sheets("format_information").Columns("AA:AB").Clear Sheets("format_information").Range("AA2").CopyFromRecordset Rst '#####################在这里改输出的位置与单元格 Rst.Close '关闭数据库连接 Conn.Close 'Set Conn = Nothing 'Set Rst = Nothing End Function第二部分为键入字符后执行搜索的功能 'textbox键盘抬起事件：即输入了文字 Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Dim i, x As Integer Dim Language As Boolean, arr1 As Variant Dim myStr As String, str_B As String Dim d As Object Dim arr, arr_key Set d = CreateObject("scripting.dictionary") Me.ListBox1.Clear myStr = Me.TextBox1.Value With Me.ListBox1 .Width = 400 .Height = 300 End With If tacolumn = 1 And tarow > 10 Then With Sheets("format_information") arr1 = .Range("a2:a" & .Range("a65535").End(xlUp).Row) For i = 1 To .Range("a65535").End(xlUp).Row - 1 '利用instr遍历找到包含输入文字的部分,并 赋值到字典里避免重复 If InStr(1, arr1(i, 1), myStr, 1) Then d(arr1(i, 1)) = "" End If Next i Me.ListBox1.List = d.keys()'listbox赋值 End With ElseIf (tacolumn = 3 Or tacolumn = 4) And tarow > 10 Then With Sheets("format_information") arr = .Range("c2:c" & .Range("c65535").End(xlUp).Row) arr1 = .Range("d2:d" & .Range("d65535").End(xlUp).Row) For i = 1 To .Range("c65535").End(xlUp).Row - 1 If InStr(1, arr(i, 1), myStr, 1) Or InStr(1, arr1(i, 1), myStr, 1) Then d(arr(i, 1) & "■" & arr1(i, 1)) = "" End If Next i Me.ListBox1.List = d.keys() End With End If End Sub第三部分为双击选取值的部分 'listbox双击事件 Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim arr If (tacolumn = 1 Or tacolumn = 2) And tarow > 10 Then '将listbox值赋予当前单元格 ActiveCell.Value = Me.ListBox1.Value Me.ListBox1.Clear Me.TextBox1 = ""'清空listbox与textbox Me.ListBox1.Visible = False'y隐藏textbox和listbox Me.TextBox1.Visible = False ElseIf (tacolumn = 3 Or tacolumn = 4) And tarow > 10 Then arr = Split(Me.ListBox1.Value, "■") ActiveCell.Value = arr(0) ActiveCell.Offset(0, 1).Value = arr(1) Me.ListBox1.Clear Me.TextBox1 = "" Me.ListBox1.Visible = False Me.TextBox1.Visible = False End If End Sub具体文件和代码可于https://github.com/smilecoc/VBA_listinput_tools下载查看 个人公众号：Smilecoc的杂货铺，欢迎关注！ |
【本文地址】