如何用VBA字典实现如下的汇总

gtxing

求大神帮忙汇总下如下数据，附件已上传，谢谢

姓名	任务			想实现的效果
苹果	A			苹果	小米	魅族
小米	B			A	B	C
魅族	C			D	E	F
苹果	D			G	A	B
小米	E			C	D	E
魅族	F			F	G
苹果	G
小米	A
魅族	B
苹果	C
小米	D
魅族	E
苹果	F
小米	G

liulang0808

楼主为什么要用字典呢？
是因为有重复数据吗？

gtxing

liulang0808 发表于 2016-9-28 14:45
楼主为什么要用字典呢？
是因为有重复数据吗？

是的，应该如何实现呢

liulang0808

1. Sub 按钮1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     arr = [a1].CurrentRegion
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For j = 2 To UBound(arr)
   
6.         d(arr(j, 1)) = d(arr(j, 1)) & "," & arr(j, 2)
   
7.     Next j
   
8.     For j = 0 To d.Count - 1
   
9.         Cells(2, j + 5) = d.keys()(j)
   
10.         str1 = Mid(d.items()(j), 2)
    
11.         If InStr(str1, ",") > 0 Then
    
12.             arr = Split(str1, ",")
    
13.             Cells(3, j + 5).Resize(UBound(arr) + 1) = WorksheetFunction.Transpose(arr)
    
14.         Else
    
15.             Cells(3, j + 5) = str1
    
16.         End If
    
17.     Next j
    
18.     Application.ScreenUpdating = True
    
19. End Sub
    

复制代码

liulang0808

供参考吧。。。。。

gtxing

liulang0808 发表于 2016-9-28 14:53
供参考吧。。。。。

谢谢大神，如果不用字典，会方便点吗

liulang0808

gtxing 发表于 2016-9-28 15:08
谢谢大神，如果不用字典，会方便点吗

不一定的。。。。

hhjjpp

或者字典嵌套
如果有重复，适合用字典

everbest2015

Sub 格式转换()
    Dim d As Object, ar, br(), i&, k&, m&, x, s
    Dim rr, t, n&
    Set d = CreateObject("Scripting.Dictionary")
    ar = Range("a1").CurrentRegion
    For i = 2 To UBound(ar)
        s = ar(i, 1)
        If Not d.exists(s) Then
            d(s) = ar(i, 2)
        Else
            d(s) = d(s) & ", " & ar(i, 2)
        End If
    Next
    ReDim br(1 To UBound(ar), 1 To d.Count)
    [E2].Resize(, 3) = application.transpose(Application.Transpose(d.keys))
    For Each x In d.keys
        n = n + 1
        rr = Split(d(x), ", ")
        For Each t In rr
            m = m + 1
            br(m, n) = rr(m - 1)
        Next
        m = 0
    Next
    Stop
    [E3].Resize(UBound(ar), 3) = br
End Sub