根据条件去重后将内容用逗号隔开

cjc209

或者
Sub 字典汇总()
    Dim arr, brr
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = Sheet2.Range("a1").CurrentRegion '数据装入数组
   
    For i = 1 To UBound(arr)
        tjz = arr(i, 1) '条件
        If d.Exists(tjz) Then '字典里存在的时候
        brr = d(tjz) '字典关键字对应的条目的值装入结果数组（可以为数组）
        If Not d1.Exists(tjz & arr(i, 2)) Then
           d1(tjz & arr(i, 2)) = ""
            brr(2) = brr(2) & "," & arr(i, 2) '要汇总的列
        End If
    Else
        ReDim brr(1 To UBound(arr, 2)) '声明动态数组 装符合条件的每列数据
        For l = 1 To UBound(arr, 2)
            brr(l) = arr(i, l) '需要的字段装入结果数组
        Next l
        d1(tjz & arr(i, 2)) = ""
    End If
    d(tjz) = brr '更新字典条目中的值
Next
If d.Count Then
    Sheet2.Range("d1").CurrentRegion.ClearContents '清除结果区的数据
    brr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(d.Items)) '数组装置
    Sheet2.Range("d1").Resize(d.Count, UBound(brr, 2)) = brr '赋值
End If
End Sub

everbest2015

Private Sub CommandButton1_Click()
    Dim ar, d As Object, i&, r&, s$, ss
    r = Sheet2.Range("a1").End(xlDown).Row
    If r > 1 Then
        ar = Sheet2.Range("a1").Resize(r, 2)
    Else
        Exit Sub
    End If
    Sheet1.[a1:b1] = Array("姓名", "属性")
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(ar)
        s = ar(i, 1)
        If s <> "" Then
            ss = ar(i, 2)
            If Not d.exists(s) Then
                d(s) = ss
            ElseIf InStr(d(s), ss) = 0 Then
                 d(s) = d(s) & ", " & ar(i, 2)
            End If
        End If
    Next
    If d.Count > 0 Then
            With Sheet1
                .Range("a2:b" & d.Count) = ""
                .Range("a2").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
            End With
            MsgBox "处理成功", 64, "提示"
    End If
End Sub

everbest2015

请参阅我的附件

准提部林

指定姓名/去重/串接:
Sub TEST()
Dim Arr, A, i&, xD, T1$, T2$, U&, N&
Set xD = CreateObject("Scripting.Dictionary")
For Each A In Range([L2], [L65536].End(xlUp))
    xD(A & "||") = 1
Next
Arr = Range([Sheet2!B1], [Sheet2!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    T1 = Arr(i, 1): T2 = Arr(i, 2): U = xD(T1)
    If xD(T1 & "||") = 0 Or xD(T1 & "|" & T2) = 1 Then GoTo 101
    If U = 0 Then N = N + 1: U = N: xD(T1) = N: Arr(U, 1) = T1: Arr(U, 2) = ""
    Arr(U, 2) = Replace(Trim(Arr(U, 2) & " " & T2), " ", ",")
    xD(T1 & "|" & T2) = 1
101: Next i
[A2:B2000].ClearContents
If N > 0 Then [A2:B2].Resize(N) = Arr
End Sub

Xl0000040.rar (13.04 KB, 下载次数: 2)

2019-1-19 14:43 上传

点击文件名下载附件

everbest2015

Sub my_test()
  Dim r%, i%, aa, m&
  Dim arr, brr
  Dim d As Object
  Set d = CreateObject("scripting.dictionary")
  Sheet1.Range("a:b").ClearContents
  With Worksheets("sheet2")
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("a2:b" & r)
  End With
  For i = 1 To UBound(arr)
    If Not d.exists(arr(i, 1)) Then
      Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    End If
   d(arr(i, 1))(arr(i, 2)) = ""
  Next
  With Worksheets("sheet1")
    .Range("a2:b" & .Rows.Count).Clear
    If d.Count > 0 Then
        ReDim brr(1 To d.Count, 1 To 2)
        For Each aa In d.keys
            m = m + 1
            brr(m, 1) = aa
            brr(m, 2) = Join(d(aa).keys, ",")
        Next
        .[a1].Resize(d.Count, 2) = brr
        Set d = Nothing
    End If
  End With
    MsgBox "成功", , "开始懂了"
End Sub

everbest2015

三楼老师的思路很棒,向您学习

ggmmlol

1. Sub test()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. ar = Sheet2.Range("a1").CurrentRegion.Resize(, 2)
   
4. r = UBound(ar)
   
5. ReDim br(1 To r, 1 To 2)
   
6. For i = 2 To r
   
7.     If d.exists(ar(i, 1)) Then
   
8.         p = d(ar(i, 1))
   
9.         If InStr("," & br(p, 2) & ",", "," & ar(i, 2) & ",") = 0 Then
   
10.             br(p, 2) = br(p, 2) & "," & ar(i, 2)
    
11.         End If
    
12.     Else
    
13.         n = n + 1
    
14.         d(ar(i, 1)) = n
    
15.         br(n, 1) = ar(i, 1)
    
16.         br(n, 2) = ar(i, 2)
    
17.     End If
    
18. Next
    
19. Sheet1.[i2].Resize(n, 2) = br
    
20. End Sub

复制代码

Kaohsing

只对本例有效：

1. Sub js()
   
2.     Application.ScreenUpdating = False
   
3.    
   
4.     Set x = CreateObject("ScriptControl")
   
5.     x.Language = "JScript"
   
6.     x.AddObject "rg", Range("a1")
   
7.     s = "var kao={ };"
   
8.     x.AddCode s
   
9.     Sheet2.Select
   
10.     r = Cells(Rows.Count, 1).End(xlUp).Row
    
11.     arr = Range("a2:b" & r)
    
12.     For i = 1 To UBound(arr)
    
13.         If Len(x.eval("kao['" & arr(i, 1) & "']")) = 0 Then
    
14.             s = "kao['" & arr(i, 1) & "']='" & arr(i, 2) & "';"
    
15.             x.AddCode s
    
16.         Else
    
17.             If InStr(x.eval("kao['" & arr(i, 1) & "']"), arr(i, 2)) = 0 Then
    
18.                 s = "kao['" & arr(i, 1) & "']='" & x.eval("kao['" & arr(i, 1) & "']") & "," & arr(i, 2) & "';"
    
19.                 x.AddCode s
    
20.             End If
    
21.         End If
    
22.     Next
    
23.     Sheet1.Select
    
24.     x.eval ("var i=2;for( k in kao){ rg(i,1)= k, rg(i,2)=kao[k],i++}; ")
    
25.     Application.ScreenUpdating = True
    
26.    
    
27.    
    
28.     MsgBox "OK!"
    
29.    
    
30. End Sub

复制代码

Kaohsing

去重求教.zip (19.89 KB, 下载次数: 2)

2019-2-2 19:23 上传

点击文件名下载附件

micch

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     With Sheets("sheet2")
   
4.         arr = .[a1].CurrentRegion
   
5.         For i = 2 To UBound(arr)
   
6.             If InStr(d(arr(i, 1)) & ",", "," & arr(i, 2) & ",") = 0 Then
   
7.                 d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
   
8.             End If
   
9.         Next
   
10.     End With
    
11.     With Sheets("sheet1")
    
12.         arr = .[a1].CurrentRegion 'A2以下是想查询的人名
    
13.         For i = 2 To UBound(arr)
    
14.             arr(i, 2) = Mid(d(arr(i, 1)), 2)
    
15.         Next
    
16.         .[a1].CurrentRegion = arr
    
17.     End With
    
18. End Sub
    

复制代码