A列相同，B列去重跟A列用逗号合并输出到C列(B列里面同一个单元格有多个水果也分开...

宏初学者

如何用vba实现：A列相同，B列去重跟A列用逗号合并输出到C列(B列里面同一个单元格有多个水果也分开合并）。。最后在E列汇总去重

由于数据很大，列举一小部分数据

limonet

嵌套函数。
=A2&","&TEXTJOIN(",",,UNIQUE(TEXTSPLIT(TEXTJOIN("-",,FILTER(B:B,A:A=A2)),,"-")))

cnmlgb9998

用公式就能解决。。。。。。。。。。。

宏初学者

limonet 发表于 2024-9-2 17:48
嵌套函数。
=A2&","&TEXTJOIN(",",,UNIQUE(TEXTSPLIT(TEXTJOIN("-",,FILTER(B:B,A:A=A2)),,"-")))

哈哈，是的，就是数据太大了，只列一部分，用公式卡死好几次了，所以想用vba看看

宏初学者

cnmlgb9998 发表于 2024-9-2 17:54
用公式就能解决。。。。。。。。。。。

就是数据太大了，用公式会卡住

ykcbf1100

VBA，去重一步到位就行了，没必要生成C列数据

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.2   去重
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     On Error Resume Next
   
4.     With Sheets("Sheet1")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 2)
   
7.         ReDim brr(1 To r, 1 To 1)
   
8.         For i = 2 To UBound(arr)
   
9.             s = arr(i, 1)
   
10.             b = Split(arr(i, 2), "-")
    
11.             st = Join(b, "，")
    
12.             If Not d.exists(s) Then
    
13.                 m = m + 1
    
14.                 d(s) = m
    
15.                 brr(m, 1) = s & "，" & st
    
16.             Else
    
17.                 r = d(s)
    
18.                 For x = 0 To UBound(b)
    
19.                     brr(r, 1) = IIf(InStr(brr(r, 1), b(x)), brr(r, 1), brr(r, 1) & "，" & b(x))
    
20.                 Next
    
21.             End If
    
22.         Next
    
23.         .[e2:e1000] = ""
    
24.         .[e2].Resize(m, 1) = brr
    
25.     End With
    
26.     Application.ScreenUpdating = True
    
27.     MsgBox "OK！"
    
28. End Sub
    
29. 
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST9()
    Dim ar, br, i&, j&, r&, dic As Object, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then
            Set dic(ar(i, 1)) = CreateObject("Scripting.Dictionary")
        End If
        dic(ar(i, 1))(ar(i, 2)) = Empty
    Next i
   
    ReDim ar(dic.Count, 0)
    ar(0, 0) = "汇总"
    For Each vKey In dic.keys
        r = r + 1
        ar(r, 0) = vKey & " ，" & Join(dic(vKey).keys, " ，")
    Next
   
    [E1].CurrentRegion.Clear
    [E1].Resize(UBound(ar) + 1) = ar
    Set dic = Nothing
    Application.ScreenUpdating = True
End Sub

   

gwjkkkkk

...............

醉眼看尘世

1. Sub test()
   
2. Dim Dic As Object, reGxp As Object, Arr, i&, j&, tmPobj As Object, tmPsubobj As Object
   
3. Set Dic = CreateObject("scripting.dictionary")
   
4. Set reGxp = CreateObject("vbscript.reGexp")
   
5. reGxp.Global = True
   
6. reGxp.Pattern = "([^\-]+)"
   
7. With Sheet1
   
8.     i = .Cells(.Rows.Count, "A").End(3).Row
   
9.     Arr = .[a1].Resize(i, 3)
   
10.     For i = 2 To UBound(Arr, 1)
    
11.     If Not Dic.exists(Arr(i, 1)) Then Set Dic(Arr(i, 1)) = CreateObject("scripting.dictionary")
    
12.         Set tmPobj = reGxp.Execute(Arr(i, 2))
    
13.         For Each tmPsubobj In tmPobj
    
14.             Dic(Arr(i, 1))(tmPsubobj.submatches(0) & "") = ""
    
15.         Next
    
16.     Next i
    
17.     For i = 2 To UBound(Arr, 1)
    
18.         Arr(i, 3) = Arr(i, 1) & "," & Join(Dic(Arr(i, 1)).keys, ",")
    
19.     Next i
    
20.     .[a1].Resize(UBound(Arr, 1), 3) = Arr
    
21.    
    
22.     ReDim Brr(1 To Dic.Count + 1, 1 To 1)
    
23.     Brr(1, 1) = "汇总"
    
24.     i = 1
    
25.     For Each d In Dic.keys
    
26.         i = i + 1
    
27.         Brr(i, 1) = d & "," & Join(Dic(d).keys, ",")
    
28.     Next d
    
29.     .[e1].Resize(UBound(Brr, 1), 1) = Brr
    
30. End With
    
31. 
    
32. End Sub
    

复制代码