查询组数据相同的问题

dfshm

附件 查询组数据相同附件.rar (302.92 KB, 下载次数: 5)

2018-9-4 07:58 上传

点击文件名下载附件

谢谢老师!

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     arr = [a1].CurrentRegion
   
5.     For j = 1 To UBound(arr)
   
6.         If Len(arr(j, 1)) > 0 Then
   
7.             If d.exists(arr(j, 2)) Then
   
8.                 Set d(arr(j, 2)) = Union(d(arr(j, 2)), Cells(j, 1).Resize(1, 2))
   
9.             Else
   
10.                 Set d(arr(j, 2)) = Cells(j, 1).Resize(1, 2)
    
11.             End If
    
12.         End If
    
13.     Next j
    
14.     For j = 0 To d.Count - 1
    
15.         If d.items()(j).Cells.Count > 2 Then d.items()(j).Interior.ColorIndex = 6
    
16.     Next j
    
17.     Application.ScreenUpdating = True
    
18. End Sub

复制代码

microyip

不知道这样的贴将会有多少人愿意回复呢？

liulang0808

附件内容供参考。。。。。。

dfshm

liulang0808 发表于 2018-9-4 08:39
附件内容供参考。。。。。。

谢谢老师帮助.看了一下,您把题意理解错了.

附件中,只在一组符合要求.

liulang0808

dfshm 发表于 2018-9-4 08:45
谢谢老师帮助.看了一下,您把题意理解错了.

附件中,只在一组符合要求.

不好意思啊，看不明白

dfshm

liulang0808 发表于 2018-9-4 09:54
不好意思啊，看不明白

A列中
18
18
相同

34
34
相同

相应
18对应的
-5831
-1225
与
34对应的
-5831
-1225

相同
(不考虑顺序,只要数字对即可)

18	-5831
18	-2940
18	-1225

34	-5831
34	-1225

就是这组符合要求.把相同的标色即可.

dfshm

概括一句话就是：

A列中，相同一组数据，比如18，与之对应的B列中的数据。

与

A列中，另一组相同一组数据，比如34，与之对应的B列中的数据

如果相同（两个）

则符合要求，把相同的标色即可。

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Dim rng As Range
   
4.     Application.ScreenUpdating = False
   
5.     arr = [a1].CurrentRegion
   
6.     str1 = [a1]
   
7.     For j = 1 To UBound(arr)
   
8.         If Not d.exists(arr(j, 1)) Then
   
9.             Set d(arr(j, 1)) = Cells(j, 2)
   
10.         Else
    
11.             Set d(arr(j, 1)) = Union(d(arr(j, 1)), Cells(j, 2))
    
12.         End If
    
13.     Next j
    
14.     For j = 0 To d.Count - 1
    
15.         
    
16.         For i = j + 1 To d.Count - 1
    
17.             Set r = Nothing
    
18.             For Each rng In d.items()(j)
    
19.                 For Each rn In d.items()(i)
    
20.                     If rng.Value = rn.Value Then
    
21.                         If r Is Nothing Then
    
22.                             Set r = Union(rng, rn)
    
23.                         Else
    
24.                             Set r = Union(r, rng, rn)
    
25.                         End If
    
26.                     End If
    
27.                 Next rn
    
28.             Next rng
    
29.             If Not r Is Nothing Then
    
30.                 If r.Cells.Count Mod 4 = 0 Then
    
31.                     r.Interior.ColorIndex = 6
    
32.                 End If
    
33.             End If
    
34.         Next i
    
35.     Next j
    
36. 
    
37.     Application.ScreenUpdating = True
    
38. End Sub

复制代码

liulang0808

看看是否满足需求吧