[已解决]4个数字一组，N组数据对比删除重复，然后非重复的再排列

szmika

4个数字一组，共有N组数据，
第一组和后面的每一组对比，第二组和后面的每一组对比，第三组合后面的每一组对比……
把重复的数据删除，把不重复的数据提取在表二，无论多少组重复，最后每组只会有4个数字是不重复的，就要得到那4个数字
如果4个数字一组和后面的每一组对比，没重复的话，就直接输出在表二

上传的示例中，A列是原始的数据，C列是处理后的数据。 剔除重复再提取.rar (7 KB, 下载次数: 12)

2014-2-15 21:23 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-2-15 23:18

…………………

跳转到最佳答案楼层

tgydslr

用vba比较好，建议发到VBA区

冠军欧洲2010

1. Sub A()
   
2.     Dim D As New Dictionary
   
3.     Dim X, Y, SR, AR
   
4.     For X = 2 To 25 Step 5
   
5.         SR = Cells(X, 1).Value & "," & Cells(X + 1, 1).Value & "," & Cells(X + 2, 1).Value & "," & Cells(X + 3, 1).Value
   
6.         D(SR) = ""
   
7.     Next
   
8.     For Y = 1 To D.Count
   
9.         Cells((Y - 1) * 5 + 1, 4) = "数据" & Y
   
10.         Cells((Y - 1) * 5 + 2, 4).Resize(D.Count, 1) = Application.WorksheetFunction.Transpose(Split(D.Keys(Y - 1), ","))
    
11.     Next
    
12. End Sub
    

复制代码

szmika

冠军欧洲2010 发表于 2014-2-15 21:46

你好，你的文件好像不大符合我的情况，A列是原始数据，C列是希望得到的数据，有点类似圆圈交集的关系，把交集的部分删除，得到剩余的。没有交集的，就直接输出

dsmch

1. Sub Macro1()
   
2. Dim arr, d, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. For i = 1 To UBound(arr)
   
6.     If Not arr(i, 1) Like "数据*" Then d(arr(i, 1)) = d(arr(i, 1)) + 1
   
7. Next
   
8. a = d.keys: b = d.items
   
9. For i = 0 To d.Count - 1
   
10.     x = s \ 4 + 1
    
11.     If b(i) = 1 Then
    
12.         s = s + 1
    
13.         arr(x + s, 1) = a(i)
    
14.         If s Mod 4 = 0 Then arr((s \ 4 - 1) * 5 + 1, 1) = "数据" & s \ 4
    
15.     End If
    
16. Next
    
17. Sheet2.Activate
    
18. Range("a1").Resize(x + s) = arr
    
19. End Sub
    

复制代码

dsmch

…………………

szmika

dsmch 发表于 2014-2-15 23:18
…………………

非常感谢！

tgydslr

感觉楼主是不是又发了重复贴呀，在哪里看到过这个帖子

szmika

dsmch 发表于 2014-2-15 23:18
…………………

你好，今天测试了，发现有问题：当不按照顺序排列时候，即中间加入一组与其他组不重复的4个数字，加入的该组不能单独直接输出。
例如：

数据1
132,1
2235
32
4,23
数据2
132,112
223534
31455
3145555
数据3
132,1
2235
31
43,1
数据4
1321111
1112235
23
433
数据5
13211112
11122353
23
433

希望得到结果：

数据1
32
4,23
31
43,1
数据2
132,112
223534
31455
3145555
数据3
1321111
1112235
13211112
11122353

dsmch

1. Sub Macro1()
   
2. Dim arr, d, i&, j&, k&, m&, n%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion
   
5. m = 1
   
6. For i = 1 To UBound(arr)
   
7.     If arr(i, 1) Like "数据*" Then
   
8.         n = 0
   
9.         For j = i + 1 To i + 4
   
10.             If Application.CountIf(Columns(1), arr(j, 1)) = 1 Then n = n + 1
    
11.         Next
    
12.         If n = 4 Then
    
13.             Cells(i, 1).Resize(5).Copy Sheet2.Cells(m, 2)
    
14.             m = m + 5
    
15.             For k = i To i + 4
    
16.                 arr(k, 1) = ""
    
17.             Next
    
18.         End If
    
19.     End If
    
20. Next
    
21. For i = 1 To UBound(arr)
    
22.     If Not arr(i, 1) Like "数据*" Then d(arr(i, 1)) = d(arr(i, 1)) + 1
    
23. Next
    
24. a = d.keys: b = d.items
    
25. For i = 0 To d.Count - 1
    
26.     x = s \ 4 + 1
    
27.     If b(i) = 1 Then
    
28.         s = s + 1
    
29.         arr(x + s, 1) = a(i)
    
30.         If s Mod 4 = 0 Then arr((s \ 4 - 1) * 5 + 1, 1) = "数据" & s \ 4
    
31.     End If
    
32. Next
    
33. Sheet2.Activate
    
34. Range("a1").Resize(x + s) = arr
    
35. End Sub
    

复制代码