一对多匹配，多个结果用逗号隔开

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.7
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheets("数据源").UsedRange
   
6.     ReDim brr(1 To UBound(arr), 1 To 2)
   
7.     For i = 2 To UBound(arr)
   
8.         s = arr(i, 1)
   
9.         If Not d.Exists(s) Then
   
10.             m = m + 1
    
11.             d(s) = m
    
12.             brr(m, 1) = arr(i, 1)
    
13.             brr(m, 2) = arr(i, 2)
    
14.         Else
    
15.             r = d(s)
    
16.             brr(r, 2) = IIf(InStr(brr(r, 2), arr(i, 2)), brr(r, 2), brr(r, 2) & "," & arr(i, 2))
    
17.         End If
    
18.     Next
    
19.     With Sheets("结果")
    
20.         .UsedRange.Offset(3) = ""
    
21.         .Range("a4").Resize(m, 2) = brr
    
22.     End With
    
23.     Set d = Nothing
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "OK！"
    
26. End Sub
    

复制代码

andy117

ykcbf1100 发表于 2024-8-7 15:29
参与一下。。。

如果还是想数据源哪样展示，及ＩＤ对应几个名词就占几行显示呢

ykcbf1100

andy117 发表于 2024-8-7 17:04
如果还是想数据源哪样展示，及ＩＤ对应几个名词就占几行显示呢

那不是就是源数据吗？还处理什么呢？

Lost_in_Star

一对多延申。
Sub Limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, i%
    Set Cn = CreateObject("ADODB.connection")
    filePath = "D:\VBA\vba项目\数据匹配\SQL方法.xlsm"
    ' 构造连接字符串
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0 Xml;HDR=YES;';Data Source=" & filePath
    On Error Resume Next
    For i = 4 To 6
        Cells(i, "C") = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(Cn.Execute("select 名称 from [数据源$] Where ID=" & Cells(i, "A")).GetRows)), ",")
        Cells(i, "D") = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(Cn.Execute("select 名称2 from [数据源$] Where ID=" & Cells(i, "A")).GetRows)), ",")
    Next i
End Sub

andy117

ykcbf1100 发表于 2024-8-7 18:29
那不是就是源数据吗？还处理什么呢？

现在数据源举例三家嘛，扩展至10家，我这次只选其中3家，然后根据ID把名称依次选出。现在大部分都是用字典重构了数据源，成为了一个新的数组。但字典好像无法一对多

kyxfyzg

测试一下还可以的

ykcbf1100

andy117 发表于 2024-8-8 08:59
现在数据源举例三家嘛，扩展至10家，我这次只选其中3家，然后根据ID把名称依次选出。现在大部分都是用字 ...

vlookup只能一对一，但字典就是可以一对多。

andy117

ykcbf1100 发表于 2024-8-8 09:14
vlookup只能一对一，但字典就是可以一对多。

我的需求见新的附件，你代码实现的效果是红色，我的需求是篮字

ykcbf1100

andy117 发表于 2024-8-8 09:23
我的需求见新的附件，你代码实现的效果是红色，我的需求是篮字

你这都不用字典

ykcbf1100

条件提取。。。

1. Sub ykcbf()   '//2024.8.8
   
2.     Dim arr, brr
   
3.     Application.ScreenUpdating = False
   
4.     arr = Sheets("数据源").UsedRange
   
5.     ReDim brr(1 To UBound(arr), 1 To 2)
   
6.     r = Cells(Rows.Count, 3).End(3).Row
   
7.     ID = ""
   
8.     For i = 4 To r
   
9.         ID = ID & "|" & Cells(i, 3)
   
10.     Next
    
11.     For i = 2 To UBound(arr)
    
12.         If InStr(ID, arr(i, 1)) Then
    
13.             m = m + 1
    
14.             brr(m, 1) = arr(i, 1)
    
15.             brr(m, 2) = arr(i, 2)
    
16.         End If
    
17.     Next
    
18.     With Sheets("结果")
    
19.         .[a4:b10000] = ""
    
20.         .Range("a4").Resize(m, 2) = brr
    
21.     End With
    
22.     Set d = Nothing
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "OK！"
    
25. End Sub
    

复制代码