求代码，一对多查找

PYX315

在网上找了好久，没有找到啊，可自己又会写，急死人了
用函数天天做起来很慢。求高人指点啊。谢谢谢谢

hlly888

可自己又会写，为什么急死人了？

LIUZHU

网上抄来的这个，其实写得挺好的

hlly888

1. Sub yy() 'hlly888
   
2. Range("b2:c65536").ClearContents
   
3. Application.ScreenUpdating = False
   
4. Dim arr, brr, dc As Object, i&, x&, kk, j%, k%, s&
   
5. Set dc = CreateObject("scripting.dictionary")
   
6. arr = Range("a2:a" & Range("a65536").End(3).Row)
   
7. brr = Sheets("工艺").Range("b2:d" & Sheets("工艺").Range("b65536").End(3).Row)
   
8. ReDim crr(1 To UBound(brr), 1 To 2)
   
9. 
   
10.   For i = 1 To UBound(arr)
    
11.       dc(arr(i, 1)) = ""
    
12.   Next
    
13.   kk = dc.keys
    
14.   For j = 0 To UBound(kk)
    
15.       For i = 1 To UBound(brr)
    
16.           If brr(i, 1) = kk(j) Then
    
17.              s = s + 1
    
18.              For k = 2 To 3
    
19.                  crr(s, k - 1) = brr(i, k)
    
20.              Next
    
21.           End If
    
22.       Next
    
23.   Next
    
24.   
    
25. [b2].Resize(s, 2) = crr
    
26. Application.ScreenUpdating = True
    
27. End Sub

复制代码

hlly888

查询问题.zip (29.23 KB, 下载次数: 222)

2015-8-18 16:50 上传

点击文件名下载附件

PYX315

hlly888 发表于 2015-8-18 16:50

谢谢，非常感谢，困扰几天的事解决了

LMY123

字典一对多查询