[已解决]问题已在附件中描述谢谢

云影

请用VBA数组解决谢谢.rar (6.55 KB, 下载次数: 25)

2013-12-21 13:00 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

Zipall

2013-12-21 13:48

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     n = Range("g63536").End(xlUp).Row - 1
   
4.     arr = Range("g2").Resize(n, 2)
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     For i = 1 To n
   
7.         dic(arr(i, 2)) = dic(arr(i, 2)) & "|" & arr(i, 1)
   
8.     Next
   
9.    
   
10.     k = dic.keys
    
11.     Range("j2").Resize(UBound(k) + 1) = Application.WorksheetFunction.Transpose(k)
    
12.    
    
13.     d = dic.items
    
14.         
    
15.     For i = 2 To UBound(k) + 2
    
16.         t = Split(d(i - 2), "|")
    
17.         dic.RemoveAll
    
18.         For j = 1 To UBound(t)
    
19.             dic(t(j)) = 0
    
20.         Next
    
21.         k = dic.keys
    
22.         Cells(i, "k").Resize(, UBound(k) + 1).Value = k
    
23.     Next
    
24.     Set dic = Nothing
    
25.     Application.ScreenUpdating = True
    
26. End Sub

复制代码

跳转到最佳答案楼层

Zipall

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     n = Range("g63536").End(xlUp).Row - 1
   
4.     arr = Range("g2").Resize(n, 2)
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     For i = 1 To n
   
7.         dic(arr(i, 2)) = dic(arr(i, 2)) & "|" & arr(i, 1)
   
8.     Next
   
9.    
   
10.     k = dic.keys
    
11.     Range("j2").Resize(UBound(k) + 1) = Application.WorksheetFunction.Transpose(k)
    
12.    
    
13.     d = dic.items
    
14.         
    
15.     For i = 2 To UBound(k) + 2
    
16.         t = Split(d(i - 2), "|")
    
17.         dic.RemoveAll
    
18.         For j = 1 To UBound(t)
    
19.             dic(t(j)) = 0
    
20.         Next
    
21.         k = dic.keys
    
22.         Cells(i, "k").Resize(, UBound(k) + 1).Value = k
    
23.     Next
    
24.     Set dic = Nothing
    
25.     Application.ScreenUpdating = True
    
26. End Sub

复制代码

大灰狼1976

字典嵌套，但是输出是结合单元格操作，不完美，期待高手的巧妙方法！

1. Private Sub CommandButton1_Click()
   
2. Dim arr, i&, d As Object
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [g1].CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.   If Not d.exists(arr(i, 2)) Then Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
   
7.   d(arr(i, 2))(arr(i, 1)) = ""
   
8. Next i
   
9. [a1].Resize(d.Count) = Application.Transpose(d.keys)
   
10. For i = 1 To d.Count
    
11.   Cells(i, 2).Resize(, d(Cells(i, 1).Value).Count) = d(Cells(i, 1).Value).keys
    
12. Next i
    
13. End Sub

复制代码

Zipall

我测了一下3万个随机数分20组, 大灰狼的21个字典,比我把一个字典用21遍快.

云影

Zipall 发表于 2013-12-21 14:01
我测了一下3万个随机数分20组, 大灰狼的21个字典,比我把一个字典用21遍快.

感谢老师关注
vba 我还不会正在学习，老师不用字典可以处理吗？

Zipall

云影 发表于 2013-12-21 14:07
感谢老师关注
vba 我还不会正在学习，老师不用字典可以处理吗？

vba获取不重复值,通常可以用字典\高级筛选或sql的distinct

相对来说字典用的更多一些,局限是更适合处理单字段的不重复值.
多字段的不重复值用高级筛选和sql方法差不多,区别是如果有条件的重复值,高级筛选需要建立条件区域,SQL直接写在语句里就好.

sliang28

采用校长下棋原理,避免了楼上多次使用字典,使用多个字典,多次写入单元格.

1. Sub sliang28()
   
2.     Dim arr, brr(1 To 10000, 1 To 500) As String
   
3.     Dim d1 As Object, d2 As Object, d3 As Object
   
4.     Dim iRow As Long, mycol As Integer
   
5.     Dim i&, j&, k&, x&
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     Set d2 = CreateObject("scripting.dictionary")
   
8.     Set d3 = CreateObject("scripting.dictionary")
   
9.         With Sheets("Sheet1")
   
10.             iRow = .Range("G65536").End(3).Row
    
11.             arr = .Range("G2:H" & iRow)
    
12.             For i = 1 To UBound(arr)
    
13.                 If Not d1.Exists(arr(i, 2)) Then '如果不存在二级分类
    
14.                     d1(arr(i, 2)) = d1.Count + 1 '记录结果数组行号
    
15.                     brr(d1(arr(i, 2)), 1) = arr(i, 2) '将二级分类写入结果数组第一列
    
16.                 End If
    
17.                 If Not d2.Exists(arr(i, 1) & arr(i, 2)) Then '如果不存在二级分类与分类合并
    
18.                     d2(arr(i, 1) & arr(i, 2)) = "" '将合并值写入字典
    
19.                     d3(d1(arr(i, 2))) = d3(d1(arr(i, 2))) + 1 '将结果数组的行号写入字典，并记录当前行的最大列号
    
20.                     brr(d1(arr(i, 2)), d3(d1(arr(i, 2))) + 1) = arr(i, 1) '按照字典记录的当前行的最大列号把分类写入结果数组
    
21.                 End If
    
22.                 If mycol < d3(d1(arr(i, 2))) Then mycol = d3(d1(arr(i, 2))) '记录结果数组的最大列号，此判断可以不要，写入时用最大列号写入，即500
    
23.             Next
    
24.             .Range("J2").Resize(d1.Count, mycol + 1) = brr
    
25.         End With
    
26. End Sub

复制代码

箫风

这个问题有意思，学习了！