Find查询与字典的应用

andysky

将数据取唯一值并生成有效性的下拉列表,用字典是首选
而且根据数据有效性的选择对象生成查询结果,用FIND较快
此类需求虽然用公式也可以实现,但是公式的缺点是要用到辅助区域,且效率太差,运算慢
用VBA一键生成
效果如下:

VBA查询.rar (110.13 KB, 下载次数: 1026)

2011-7-18 23:19 上传

点击文件名下载附件

Sub 生成材料名称()
On Error Resume Next
    Dim Dic1, str As String
    Set Dic1 = CreateObject("scripting.dictionary")
    For Item = 2 To Cells(Rows.Count, 3).End(xlUp).Row
        Dic1.Item(Cells(Item, 3).Value) = Cells(Item, 3).Value
    Next
    With [k3].Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(Dic1.items, ",")
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target(1).Address = "$K$3" Then
        If Len(Target(1)) > 0 Then
            Range("L3:L10000").Clear
            Dim cell As Range, firstAddress As String, arr(1 To 10000, 1 To 1), i As Integer
            With Worksheets(1).Range("C:C")
                Set cell = .Find(Target, LookAt:=xlWhole, LookIn:=xlValues)
                If Not cell Is Nothing Then
               
                    firstAddress = cell.Address
                    Do
                    i = i + 1
                       arr(i, 1) = cell.Offset(0, 1).Value
                        Set cell = .FindNext(cell)
                    Loop While cell.Address <> firstAddress
                End If
            End With
            With [l3].Resize(i, 1)
            .Value = arr
            .Borders.LineStyle = xlContinuous
            .HorizontalAlignment = xlCenter
            End With
        End If
    End If
End Sub

_______________________________________

 

[ 本帖最后由 andysky 于 2011-7-19 12:58 编辑 ]

祝洪忠

收下学习了 感谢罗版主

AVEL

感谢罗版分享。
个人感觉用字典加数组 应该不会比字典加FIND 来的慢吧。

Zamyi

二点数建议：
1、用数组不会比FIND差，2、在Worksheet_Change中改变单元格加Application.EnableEvents开关，不必做无谓的循环触动。

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target(1).Address = "$K$3" Then
   
3.   s = Target(1)
   
4.   If Len(s) > 0 Then
   
5.     r = Range("d2", [c65536].End(3))
   
6.     For i = 1 To UBound(r)
   
7.       If r(i, 1) = s Then
   
8.         j = j + 1
   
9.         r(j, 1) = r(i, 2)
   
10.       End If
    
11.     Next
    
12.     Range("L3:L10000").Clear
    
13.     With [l3].Resize(j)
    
14.       Application.EnableEvents = False
    
15.       .Value = r
    
16.       Application.EnableEvents = True
    
17.       .Borders.LineStyle = xlContinuous
    
18.       .HorizontalAlignment = xlCenter
    
19.     End With
    
20.   End If
    
21. End If
    
22. End Sub
    

复制代码

[ 本帖最后由 Zamyi 于 2011-7-18 15:57 编辑 ]

R生

收下学习了 感谢罗版主

李巴

罗总出品，我来学下。好久不见

blackttea1

收下学习了 感谢罗版主

白云2011

Sub 數組()
Dim r, L$, i&, j％
r = Range("d2", [c65536].End(3)): L = [k3]
For i = 1 To UBound(r)
If r(i, 1) = L Then j = j + 1: r(j, 1) = r(i, 2)
Next
[l3].Resize(j).Value = r
End Sub

CTFuture

不知道什么时候能学到罗老师的1‰不

岁寒三友

罗版出手定会不凡！