VBA 下拉菜单 模糊匹配下拉选项

394396755

如题：
用VBA做下拉菜单，并可以输入文字模糊匹配下拉选项
VBA下拉菜单模糊匹配.zip (6.79 KB, 下载次数: 51)

2022-3-23 19:10 上传

点击文件名下载附件

microyip

1. Public dicValidation As Object
   
2. 
   
3. Sub CreateValidation(ByVal bForce As Boolean)
   
4.     Dim vData As Variant, nRow As Long
   
5.    
   
6.     If bForce Or dicValidation Is Nothing Then
   
7.         Set dicValidation = CreateObject("Scripting.Dictionary")
   
8.         With Sheet2
   
9.             vData = .[B1].Resize(.Cells(.Rows.Count, 2).End(xlUp).Row).Value
   
10.             For nRow = 1 To UBound(vData)
    
11.                 If Trim(vData(nRow, 1)) <> "" Then dicValidation(Trim(vData(nRow, 1))) = 0
    
12.             Next
    
13.             .[Z:Z].ClearContents
    
14.             If dicValidation.Count = 1 Then
    
15.                 .[Z1] = dicValidation.Keys()(0)
    
16.             ElseIf dicValidation.Count > 0 Then
    
17.                 .[Z1].Resize(dicValidation.Count) = Application.WorksheetFunction.Transpose(dicValidation.Keys())
    
18.             End If
    
19.         End With
    
20.         
    
21.         With Sheet1.[B3].Validation
    
22.             .Delete
    
23.             If dicValidation.Count > 0 Then
    
24.                 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Sheet2!$Z$1:$Z$" & dicValidation.Count
    
25.                 .IgnoreBlank = True
    
26.                 .InCellDropdown = True
    
27.                 .InputTitle = ""
    
28.                 .ErrorTitle = ""
    
29.                 .InputMessage = ""
    
30.                 .ErrorMessage = ""
    
31.                 .IMEMode = xlIMEModeNoControl
    
32.                 .ShowInput = True
    
33.                 .ShowError = True
    
34.             End If
    
35.         End With
    
36.     End If
    
37. End Sub

复制代码

microyip

附上附件以供参考

Liu星

VBA下拉菜单模糊匹配.zip (16.49 KB, 下载次数: 123)

2022-3-23 20:54 上传

点击文件名下载附件

星河中的一粒沙

Liu星 发表于 2022-3-23 20:54

运行起来很不流畅，有BUG啊