[已解决]显示的问题

llplj

大虾们，我有个问题请大家帮助了 附件有例子。

最佳答案

月排行榜 / 总排行榜

无聊的疯子

2013-3-19 09:28

用代码运行一下就行了

1. 
   
2. Sub cc()
   
3. Dim Arr(), Hx As Long
   
4. Dim D As Object
   
5.   Set D = CreateObject("scripting.dictionary")
   
6.   With Sheets("Sheet1")
   
7.     Hx = .Range("A65536").End(xlUp).Row
   
8.     Arr = .Range("A2:B" & Hx).Value
   
9.     For Hx = 1 To UBound(Arr)
   
10.       If D.exists(Arr(Hx, 1)) Then
    
11.         Debug.Print D.Item(Arr(Hx, 1))
    
12.         D(Arr(Hx, 1)) = D.Item(Arr(Hx, 1)) & "" & Arr(Hx, 2)
    
13.       Else
    
14.         D.Add Arr(Hx, 1), Arr(Hx, 2)
    
15.       End If
    
16.     Next
    
17.     .Range("F2").Resize(D.Count, 1).Value = Application.Transpose(D.keys)
    
18.     .Range("G2").Resize(D.Count, 1).Value = Application.Transpose(D.items)
    
19.   End With
    
20. End Sub
    

复制代码

跳转到最佳答案楼层

无聊的疯子

用代码运行一下就行了

1. 
   
2. Sub cc()
   
3. Dim Arr(), Hx As Long
   
4. Dim D As Object
   
5.   Set D = CreateObject("scripting.dictionary")
   
6.   With Sheets("Sheet1")
   
7.     Hx = .Range("A65536").End(xlUp).Row
   
8.     Arr = .Range("A2:B" & Hx).Value
   
9.     For Hx = 1 To UBound(Arr)
   
10.       If D.exists(Arr(Hx, 1)) Then
    
11.         Debug.Print D.Item(Arr(Hx, 1))
    
12.         D(Arr(Hx, 1)) = D.Item(Arr(Hx, 1)) & "" & Arr(Hx, 2)
    
13.       Else
    
14.         D.Add Arr(Hx, 1), Arr(Hx, 2)
    
15.       End If
    
16.     Next
    
17.     .Range("F2").Resize(D.Count, 1).Value = Application.Transpose(D.keys)
    
18.     .Range("G2").Resize(D.Count, 1).Value = Application.Transpose(D.items)
    
19.   End With
    
20. End Sub
    

复制代码

E路人

1. Sub test() '字典嵌套字典
   
2. Dim i&, arr, arr1()
   
3. Dim d As New Dictionary
   
4. arr = Range([A2], [B65536].End(3))
   
5. For i = 1 To UBound(arr, 1)
   
6. If Not d.Exists(arr(i, 1)) Then
   
7. Set d(arr(i, 1)) = New Dictionary
   
8. d(arr(i, 1))(arr(i, 2)) = ""
   
9. End If
   
10. d(arr(i, 1))(arr(i, 2)) = ""
    
11. Next i
    
12. ReDim arr1(0 To d.Count - 1, 1 To 2)
    
13. For i = 0 To d.Count - 1
    
14. arr1(i, 1) = d.Keys(i)
    
15. arr1(i, 2) = Join(d.Items(i).Keys(), "/")
    
16. Next i
    
17. [F2:G100].ClearContents
    
18. [F2].Resize(d.Count, 2) = arr1
    
19. End Sub
    

复制代码

llplj

E路人 发表于 2013-3-19 09:41

谢谢你 因为我不太懂VBA ，所以用最佳答案直接就好了 你的代码我复制了好像有点问题 不过还是很感谢