exl下拉模糊筛选

leilay · 发表于 2013-3-11 17:30

如附件。
我有一个sheet用来放基本数据，名称什么的。
另外一个sheet就是有一列是下拉选择这个sheet里面的所有项。
但是项目太多下拉鼠标选择很有难度。

不知道能不能输入内容后自动筛选，而且是模糊筛选。不用完全匹配。
就是比如：输入a，就会出现
1a
a1
等包含有a的内容。

exl下拉模糊筛选.zip (7.6 KB, 下载次数: 137)

fzkoko · 发表于 2013-3-11 19:57

试试看

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" And Len(Target.Value) Then
      Dim d As Object, Arr
      Arr = Sheets("list").Range("A1").CurrentRegion
      Set d = CreateObject("scripting.dictionary")
      For I = 1 To UBound(Arr)
         If InStr(Arr(I, 1), Cells(1, 1).Value) Then
            d(Arr(I, 1)) = ""
         End If
      Next

      If d.Count > 0 Then
         With Range("A2:A65536")
            .Validation.Delete
            .Validation.Add xlValidateList, , Formula1:=Join(d.KEYS, ",")
         End With
      End If
End If

End Sub

蓝桥玄霜 · 发表于 2013-3-11 21:11

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer
Me.ListBox1.Clear
Arr = Sheet2.[a1].CurrentRegion
Me.TextBox1.Value = ActiveCell.Value '将活动单元值赋给文本框
If Target.Count = 1 Then
If Target.Address = "$A$1" Then
With Me.TextBox1
.Visible = True
.Top = Target.Top
.Left = Target.Left
.Width = Target.Width
.Height = Target.Height * 1.5
.Activate
.Text = ""
End With
With Me.ListBox1
.Visible = True
.Top = Target.Top
.Left = Target.Left + Target.Width
.Width = Target.Width * 1.5
.Height = 139.25
For i = 2 To UBound(Arr)
.AddItem Arr(i, 1)
Next
End With
Else
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End If
End If
End Sub

复制代码

蓝桥玄霜 · 发表于 2013-3-11 21:12

请见附件。

leilay · 发表于 2013-3-11 22:25

蓝桥玄霜发表于 2013-3-11 21:12
请见附件。

下拉是模糊搜索的，不过只有a1如果我要a列所有单元格都可以呢？除了a1，因为a1是标题。

leilay · 发表于 2013-3-11 22:34

If Target.Column = 1 Then
试了一下，发现这样是一整列的。

leilay · 发表于 2013-3-11 22:37

又改成这样：
If Target.Column = 1 And Target.Address <> "$A$1" Then
就可以了哈。搜索了下这个的用法哈

leilay · 发表于 2013-3-11 22:42

蓝桥玄霜发表于 2013-3-11 21:12
请见附件。

改了，虽然是实现了，不过还是有个小bug
就是选中后那个框会显示绿色。要点一下才会显示内容。

leilay · 发表于 2013-3-12 08:44

leilay 发表于 2013-3-11 22:42
改了，虽然是实现了，不过还是有个小bug
就是选中后那个框会显示绿色。要点一下才会显示内容。

改成这样就可以了，哈。乱来的。不知道有没有问题就是。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Integer
Me.ListBox1.Clear
Arr = Sheet2.[a1].CurrentRegion
Me.TextBox1.Value = ActiveCell.Value '将活动单元值赋给文本框
If Target.Count = 1 Then
If Target.Column = 1 And Target.Address <> "$A$1" Then
With Me.TextBox1
.Visible = True
.Top = Target.Top
.Left = Target.Left
.Width = Target.Width
.Height = Target.Height
.Activate
.Text = ""
End With
With Me.ListBox1
.Visible = True
.Top = Target.Top
.Left = Target.Left + Target.Width
.Width = Target.Width + 30
.Height = 140
For i = 2 To UBound(Arr)
.AddItem Arr(i, 1)
Next
End With
Else
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End If
End If
End Sub
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim i As Integer
Dim myStr As String
Me.ListBox1.Clear
With Me.TextBox1
For i = 1 To Len(.Value)
myStr = myStr & LCase(Mid$(.Value, i, 1))
Next
End With
For i = 2 To UBound(Arr)
If InStr(Arr(i, 1), myStr) Then
Me.ListBox1.AddItem Arr(i, 1)
End If
Next
End Sub
Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyReturn Then
ActiveCell.Value = ListBox1.Value
Me.ListBox1.Clear
Me.TextBox1 = ""
Me.ListBox1.Visible = False
Me.TextBox1.Visible = False
End If
End Sub
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

复制代码

l52376589 · 发表于 2013-11-28 15:46

受益匪浅，感谢楼主和蓝桥老师

		自动登录	找回密码
密码			免费注册

[求助] exl下拉模糊筛选