字典，1对多查询

olin12345

使用字典查询，1对多个应该怎么输入，请老师帮忙写个范例学习。

ykcbf1100

2级字典，写得复杂了一点，可以更简单。

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.5.25  查询
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("数据源")
   
7.     arr = sh.UsedRange
   
8.     bt = 1        '//标题行数
   
9.     col = 1       '//列号
   
10.     For i = bt + 1 To UBound(arr)
    
11.         s = arr(i, col)
    
12.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
13.         d(s)(i) = Application.Index(arr, i)
    
14.     Next
    
15.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
16.     With Sheets("结果")
    
17.         st = .[b2].Value
    
18.         For Each k In d.keys
    
19.             If st = k Then
    
20.                 For Each kk In d(k).keys
    
21.                     m = m + 1
    
22.                     For j = 1 To UBound(arr, 2)
    
23.                         brr(m, j) = arr(kk, j)
    
24.                     Next
    
25.                 Next
    
26.             End If
    
27.         Next
    
28.         .[a4:d1000] = ""
    
29.         .[a4].Resize(m, UBound(arr, 2)) = brr
    
30.     End With
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    

复制代码

LIUZHU

没有使用字典，其实，用公式也可以

LIUZHU

JSA代码，供参考

1. function 筛选(){
   
2.         let arr=Sheets.Item("数据源").Range("a1").CurrentRegion.Value2.filter((x,i)=>i==0 || x[0]==Range("b2").Value2);
   
3.         Range("4:"+ Math.max(4,Range("a"+ Rows.Count).End(xlUp).Row)).ClearContents();
   
4.         Range("a3").Resize(arr.length,arr[0].length).Value2=arr;
   
5. }

复制代码

LIUZHU

附件，WPS测试JS宏

半百

olin12345

LIUZHU 发表于 2024-5-24 15:54
没有使用字典，其实，用公式也可以

谢谢老师，公式也会，单个对单的提取用字典会一点，主要是想学习一下这种一对多的。

ykcbf1100

其实可以不用字典，纯数组更简单。

ykcbf1100

数组法。。。

1. Sub ykcbf2()   '//2024.5.25  查询,纯数组
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("数据源")
   
5.     arr = sh.UsedRange
   
6.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
7.     With Sheets("结果")
   
8.         st = .[b2].Value
   
9.         For i = 2 To UBound(arr)
   
10.             If arr(i, 1) = st Then
    
11.                 m = m + 1
    
12.                 For j = 1 To UBound(arr, 2)
    
13.                     brr(m, j) = arr(i, j)
    
14.                 Next
    
15.             End If
    
16.         Next
    
17.         .[a4:d1000] = ""
    
18.         .[a4].Resize(m, UBound(arr, 2)) = brr
    
19.     End With
    
20.     Application.ScreenUpdating = True
    
21.     MsgBox "OK！"
    
22. End Sub
    

复制代码