[已解决]VBA数据字典求助（数据透视）

fuclot

字典.rar (2.33 KB, 下载次数: 25)

2014-12-21 22:10 上传

点击文件名下载附件

详见附件。
从数据源中剔除重复的部分，即每种信息只留下一个到主表中（相当于数据透析了一下）。
希望可以满足数据源中行、列的增减。

谢谢大师们。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-22 10:51

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, k%, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets("数据源").Range("a1").CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6. For i = 1 To UBound(arr)
   
7.     p = ""
   
8.     For j = 1 To UBound(arr, 2)
   
9.         p = p & "," & arr(i, j)
   
10.     Next
    
11.     If Not d.exists(p) Then
    
12.         s = s + 1
    
13.         d(p) = ""
    
14.         For k = 1 To UBound(arr, 2)
    
15.             brr(s, k) = arr(i, k)
    
16.         Next
    
17.     End If
    
18. Next
    
19. Sheets("主表").Range("a1").Resize(s, UBound(brr, 2)) = brr
    
20. End Sub

复制代码

跳转到最佳答案楼层

wayy

字典可以达到不重复值的要求，但如果是多列，需要先合并，然后再分列。
建议先学习一下字典的相关贴子，搜字典会有很多。

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, k%, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets("数据源").Range("a1").CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6. For i = 1 To UBound(arr)
   
7.     p = ""
   
8.     For j = 1 To UBound(arr, 2)
   
9.         p = p & "," & arr(i, j)
   
10.     Next
    
11.     If Not d.exists(p) Then
    
12.         s = s + 1
    
13.         d(p) = ""
    
14.         For k = 1 To UBound(arr, 2)
    
15.             brr(s, k) = arr(i, k)
    
16.         Next
    
17.     End If
    
18. Next
    
19. Sheets("主表").Range("a1").Resize(s, UBound(brr, 2)) = brr
    
20. End Sub

复制代码

dsmch

………………