[已解决]如何用代码挑出相同的组数据？

静小

附件 查询相同一组附件.zip (141.15 KB, 下载次数: 7)

2013-10-23 08:16 上传

点击文件名下载附件

谢谢各位老师！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-10-23 09:09

这个效率比上一个代码高多了。

1. Sub test2()
   
2.     Dim arr1, arr2, result(1 To 1000, 1 To 1)
   
3.     Dim j As Integer, m As Integer
   
4.     Dim dic1 As Object, dic2 As Object
   
5.     Dim str1 As String, key
   
6.     Dim t#
   
7.     t = Timer
   
8.    
   
9.     Set dic1 = CreateObject("scripting.dictionary")
   
10.     Set dic2 = CreateObject("scripting.dictionary")
    
11.    
    
12.     arr1 = Range("a1").CurrentRegion.Value
    
13.     arr2 = Range("f1").CurrentRegion.Value
    
14.    
    
15.     If Not (IsArray(arr1) Or IsArray(arr2)) Then Exit Sub
    
16.    
    
17.     For j = LBound(arr1) To UBound(arr1)
    
18.         For m = LBound(arr1, 2) To UBound(arr1, 2) - 1
    
19.             str1 = str1 & arr1(j, m) & "#"
    
20.         Next
    
21.         str1 = str1 & arr1(j, m)
    
22.         dic1(str1) = ""
    
23.         str1 = ""
    
24.     Next
    
25. 
    
26.     For j = LBound(arr2) To UBound(arr2)
    
27.         For m = LBound(arr2, 2) To UBound(arr2, 2) - 1
    
28.             str1 = str1 & arr2(j, m) & "#"
    
29.         Next
    
30.         str1 = str1 & arr2(j, m)
    
31.         dic2(str1) = ""
    
32.         str1 = ""
    
33.     Next
    
34.    
    
35.     m = 0
    
36. 
    
37.     For Each key In dic1.keys
    
38.         If dic2.exists(key) Then
    
39.             m = m + 1
    
40.             result(m, 1) = key
    
41.         End If
    
42.     Next
    
43.    
    
44.     If m Then
    
45.         Application.ScreenUpdating = False
    
46.         With Range("p1")
    
47.             .CurrentRegion.ClearContents
    
48.             .Resize(m).Value = result
    
49.             .CurrentRegion.TextToColumns Destination:=Range("P1"), Other:=True, OtherChar:="#"
    
50.             .Activate
    
51.         End With
    
52.         Application.ScreenUpdating = True
    
53.         MsgBox "完成", vbInformation
    
54.     End If
    
55.     t = Timer - t
    
56.     Debug.Print "用时:" & t & " 秒"
    
57. End Sub

复制代码

跳转到最佳答案楼层

CheryBTL

二列数据不是同一行数据一一对应的相等吧？

静小

CheryBTL 发表于 2013-10-23 08:37
二列数据不是同一行数据一一对应的相等吧？

l四列成一行，为一组。

两组的四个数，都要一致。

谢谢老师。

CheryBTL

见以下代码所示：

1. Sub EP()
   
2.     Dim i As Integer, m As Integer, Rnum As Integer
   
3.     Dim ar1, ar2, re
   
4.     ar1 = Sheets(2).Range("A1").CurrentRegion
   
5.     ar2 = Sheets(2).Range("F1").CurrentRegion
   
6.     ReDim re(1 To UBound(ar1), 1 To 4)
   
7.     For i = 1 To UBound(ar1)
   
8.         m = 0
   
9.         For j = 1 To UBound(ar2)
   
10.             If ar1(i, 1) = ar2(j, 1) And ar1(i, 2) = ar2(j, 2) And ar1(i, 3) = ar2(j, 3) And ar1(i, 4) = ar2(j, 4) Then
    
11.                 m = m + 1
    
12.                 Rnum = Rnum + 1
    
13.                 re(Rnum, 1) = ar1(i, 1)
    
14.                 re(Rnum, 2) = ar1(i, 2)
    
15.                 re(Rnum, 3) = ar1(i, 3)
    
16.                 re(Rnum, 4) = ar1(i, 4)
    
17.                 Exit For
    
18.             End If
    
19.         Next j
    
20.     Next i
    
21.     Sheets(2).[p1].Resize(UBound(re), 4) = re
    
22. End Sub
    

复制代码

查询相同一组附件.rar (107.48 KB, 下载次数: 2)

2013-10-23 08:40 上传

点击文件名下载附件

CheryBTL

静小 发表于 2013-10-23 08:40
l四列成一行，为一组。

两组的四个数，都要一致。

我知道，我是说第组数据不用在同一行吧？
以上附件是按所有组数据是否相同来确定的。

hwc2ycy

1. Sub test1()
   
2.     Dim arr1, arr2, result(1 To 1000, 1 To 1)
   
3.     Dim i As Integer, j As Integer
   
4.     Dim m As Integer
   
5.     Dim dic1 As Object
   
6.     Dim dic2 As Object
   
7.     Dim key
   
8.    
   
9.     Set dic1 = CreateObject("scripting.dictionary")
   
10.     Set dic2 = CreateObject("scripting.dictionary")
    
11.    
    
12.     arr1 = Range("a1").CurrentRegion.Value
    
13.     arr2 = Range("f1").CurrentRegion.Value
    
14.    
    
15.     If Not (IsArray(arr1) Or IsArray(arr2)) Then Exit Sub
    
16.    
    
17.     i = UBound(arr1)
    
18.     If UBound(arr1) > UBound(arr2) Then i = UBound(arr2)
    
19. 
    
20.     For j = LBound(arr1) To i
    
21.         dic1(Join(WorksheetFunction.Index(arr1, j, 0), "#")) = ""
    
22.         dic2(Join(WorksheetFunction.Index(arr2, j, 0), "#")) = ""
    
23.     Next
    
24. 
    
25.     If i = UBound(arr1) Then
    
26.         For j = i + 1 To UBound(arr2)
    
27.             dic2(Join(WorksheetFunction.Index(arr2, j, 0), "#")) = ""
    
28.         Next
    
29.     Else
    
30.         For j = i + 1 To UBound(arr1)
    
31.             dic1(Join(WorksheetFunction.Index(arr1, j, 0), "#")) = ""
    
32.         Next
    
33.     End If
    
34. 
    
35. 
    
36.     For Each key In dic1.keys
    
37.         If dic2.exists(key) Then
    
38.             m = m + 1
    
39.             result(m, 1) = key
    
40.         End If
    
41.     Next
    
42.    
    
43.     If m Then
    
44.         Application.ScreenUpdating = False
    
45.         With Range("p1")
    
46.             .CurrentRegion.ClearContents
    
47.             .Resize(m).Value = result
    
48.             .CurrentRegion.TextToColumns Destination:=Range("P1"), Other:=True, OtherChar:="#"
    
49.             .Activate
    
50.         End With
    
51.         Application.ScreenUpdating = True
    
52.     End If
    
53. End Sub

复制代码

hwc2ycy

按楼主的要求来是求两组中的交集吧。

hwc2ycy

这个效率比上一个代码高多了。

1. Sub test2()
   
2.     Dim arr1, arr2, result(1 To 1000, 1 To 1)
   
3.     Dim j As Integer, m As Integer
   
4.     Dim dic1 As Object, dic2 As Object
   
5.     Dim str1 As String, key
   
6.     Dim t#
   
7.     t = Timer
   
8.    
   
9.     Set dic1 = CreateObject("scripting.dictionary")
   
10.     Set dic2 = CreateObject("scripting.dictionary")
    
11.    
    
12.     arr1 = Range("a1").CurrentRegion.Value
    
13.     arr2 = Range("f1").CurrentRegion.Value
    
14.    
    
15.     If Not (IsArray(arr1) Or IsArray(arr2)) Then Exit Sub
    
16.    
    
17.     For j = LBound(arr1) To UBound(arr1)
    
18.         For m = LBound(arr1, 2) To UBound(arr1, 2) - 1
    
19.             str1 = str1 & arr1(j, m) & "#"
    
20.         Next
    
21.         str1 = str1 & arr1(j, m)
    
22.         dic1(str1) = ""
    
23.         str1 = ""
    
24.     Next
    
25. 
    
26.     For j = LBound(arr2) To UBound(arr2)
    
27.         For m = LBound(arr2, 2) To UBound(arr2, 2) - 1
    
28.             str1 = str1 & arr2(j, m) & "#"
    
29.         Next
    
30.         str1 = str1 & arr2(j, m)
    
31.         dic2(str1) = ""
    
32.         str1 = ""
    
33.     Next
    
34.    
    
35.     m = 0
    
36. 
    
37.     For Each key In dic1.keys
    
38.         If dic2.exists(key) Then
    
39.             m = m + 1
    
40.             result(m, 1) = key
    
41.         End If
    
42.     Next
    
43.    
    
44.     If m Then
    
45.         Application.ScreenUpdating = False
    
46.         With Range("p1")
    
47.             .CurrentRegion.ClearContents
    
48.             .Resize(m).Value = result
    
49.             .CurrentRegion.TextToColumns Destination:=Range("P1"), Other:=True, OtherChar:="#"
    
50.             .Activate
    
51.         End With
    
52.         Application.ScreenUpdating = True
    
53.         MsgBox "完成", vbInformation
    
54.     End If
    
55.     t = Timer - t
    
56.     Debug.Print "用时:" & t & " 秒"
    
57. End Sub

复制代码

CheryBTL

hwc2ycy 发表于 2013-10-23 09:09
这个效率比上一个代码高多了。

还是烟花看的仔细，没注意原数据中还有真重复的。
不知道楼主对重复时的数据是怎么处理了？ 不过要是彩票啥的，重复也应该是要的吧，呵呵

静小

CheryBTL 发表于 2013-10-23 09:13
还是烟花看的仔细，没注意原数据中还有真重复的。
不知道楼主对重复时的数据是怎么处理了？ 不过要是彩票 ...

比如：
如果ABCD  中有两组或多组，与FGHI中的一组都相同，也取一组即可。重复很罕见，但不是没有。

谢谢各位老师帮助。