1对多查找

liujun1120

求助，需要用VBA代码完成

1，结论图1
2，数据源图2
目前我是用函数完成的，但是我实际数量量太多运行很卡
需通过数据源的F列&G列去查找B列的结果，结果输出到结论表。

备注：数据源实际有重复的数据

蓝桥玄霜

合并的例子：

LIUZHU

JSA版本

LIUZHU

WPS打开测试

feilanga

1. Sub zc()
   
2.     Dim dic As Object
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     arr = Sheet3.Range("A1:I" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row)
   
5.     For i = 2 To UBound(arr)
   
6.         Key = arr(i, 6) & "," & arr(i, 7)
   
7.         If Not dic.Exists(Key) Then
   
8.             dic(Key) = arr(i, 2)
   
9.         Else
   
10.             dic(Key) = dic(Key) & "," & arr(i, 2)
    
11.         End If
    
12.     Next
    
13.     keys = dic.keys
    
14.     items = dic.items
    
15.     ReDim brr(1 To dic.Count, 1 To 3)
    
16.     For i = 0 To dic.Count - 1
    
17.         k = k + 1
    
18.         s = Split(keys(i), ",")
    
19.         brr(k, 1) = s(0)
    
20.         brr(k, 2) = s(1)
    
21.         brr(k, 3) = items(i)
    
22.     Next
    
23.     Sheet1.Range("E2:G" & Rows.Count).ClearContents
    
24.     Sheet1.Range("e2").Resize(k, 3) = brr
    
25. End Sub
    

复制代码

fzxba

1对多查找.rar (92.27 KB, 下载次数: 19)

2023-7-7 09:44 上传

点击文件名下载附件

ykcbf1100

参与一下。

liujun1120

，感谢各位大咖。

yanglinzi

参与一下。。。

yanglinzi

参与一下。。。。