[已解决]提取相同数据的问题

李全有

附件 提取数据附件.rar (62.12 KB, 下载次数: 4)

2015-3-24 10:53 上传

点击文件名下载附件
谢谢各位老师！

最佳答案

月排行榜 / 总排行榜

dsmch

2015-3-24 11:27

………………

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, p$$, j%, s&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. [n:q] = ""
   
6. n = UBound(arr, 2): s = 1
   
7. For i = 1 To UBound(arr)
   
8.     p = ""
   
9.     For j = 1 To n
   
10.         p = p & "," & arr(i, j)
    
11.     Next
    
12.     If Not d.exists(p) Then
    
13.         d(p) = i
    
14.     Else
    
15.         d(p) = d(p) & "," & i
    
16.     End If
    
17. Next
    
18. b = d.items
    
19. For i = 0 To d.Count - 1
    
20.     If InStr(b(i), ",") Then
    
21.         x = Split(b(i), ",")
    
22.         Cells(s, "n").Resize(UBound(x) + 1, n) = Cells(x(0), 1).Resize(1, n).Value
    
23.     End If
    
24.     s = Range("n65536").End(xlUp).Row + 2
    
25. Next
    
26. End Sub

复制代码

dsmch

………………