匹配之后列在同一单元格内

aquariusxiao

各位大佬，具体需求是这样：
每个订单号（I列）是一张签单，客户要求每张签单以对应的交货号（H列）命名，因为一张签单对应多个交货号，目前手工将交货号对应地列在一个单元格内再复制黏贴为签单命名，非常繁琐，特别是交货号多的情况

公司的excel版本是16版无法使用textjoin函数
请教各位大佬是否有16版能用的函数公式或使用VBA取得S列和T列的结果，万分感谢！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.15
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With Sheets("Sheet1")
   
6.         r = .Cells(Rows.Count, "h").End(3).Row
   
7.         arr = .[h1].Resize(r, 2)
   
8.         ReDim brr(1 To UBound(arr), 1 To 2)
   
9.         For i = 2 To UBound(arr)
   
10.             s = arr(i, 2)
    
11.             If Not d.Exists(s) Then
    
12.                 m = m + 1
    
13.                 d(s) = m
    
14.                 brr(m, 1) = arr(i, 2)
    
15.                 brr(m, 2) = CStr(arr(i, 1))
    
16.             Else
    
17.                 r = d(s)
    
18.                 brr(r, 2) = IIf(InStr(brr(r, 2), CStr(arr(i, 1))), brr(r, 2), brr(r, 2) & "/" & arr(i, 1))
    
19.             End If
    
20.         Next
    
21.         .[s2].Resize(10000, 2) = ""
    
22.         .Range("s2").Resize(m, 2) = brr
    
23.     End With
    
24.     Set d = Nothing
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub
    
28. 
    

复制代码

Qs18

Sub qs()
Dim arr, i, dic
Set dic = CreateObject("scripting.dictionary")
arr = Sheet1.Range("h2:k" & Sheet1.Cells(Rows.Count, "k").End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
    s = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    If Not dic.exists(s) Then
        m = m + 1
        dic(s) = m
        For j = 1 To 4
            brr(m, j) = arr(i, j)
        Next
    Else
        rw = dic(s)
        brr(rw, 4) = brr(rw, 4) + arr(i, 4)
    End If
Next
Sheet2.Range("h2").Resize(m, 4) = brr
End Sub

Qs18

试试.........

Qs18

试试.............