[已解决](求助）怎么样才能快速锁定共同点？

yesddd

附件如右 查询共同点附件.rar (7.73 KB, 下载次数: 10)

2012-9-8 11:33 上传

点击文件名下载附件

感谢各位老师！

最佳答案

月排行榜 / 总排行榜

cbg2008

2012-9-8 12:20

1. Sub test()
   
2.     Dim arr, d1, d2
   
3.     Dim i As Long, j As Long, x As Long
   
4.     Cells.Interior.ColorIndex = xlNone
   
5.     i = Cells(Rows.Count, 1).End(xlUp).Row
   
6.     j = Cells(1, Columns.Count).End(xlToLeft).Column
   
7.     arr = Range(Cells(1, 1), Cells(i, j))
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     Set d2 = CreateObject("scripting.dictionary")
   
10.     For i = 1 To UBound(arr)
    
11.         d1.RemoveAll
    
12.         d2.RemoveAll
    
13.         For x = (j + 1) / 3 + 1 To (j + 1) * 2 / 3 - 1
    
14.             d1(arr(i, x)) = ""
    
15.         Next
    
16.         For x = (j + 1) * 2 / 3 + 1 To UBound(arr, 2)
    
17.             d2(arr(i, x)) = ""
    
18.         Next
    
19.         For x = 1 To (j + 1) / 3 - 1
    
20.             If d1.exists(arr(i, x)) And d2.exists(arr(i, x)) Then
    
21.                 Cells(i, x).Interior.ColorIndex = 6
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     Set d1 = Nothing
    
26.     Set d2 = Nothing
    
27. End Sub

复制代码

跳转到最佳答案楼层

cbg2008

1. Sub test()
   
2.     Dim arr, d1, d2
   
3.     Dim i As Long, j As Long, x As Long
   
4.     Cells.Interior.ColorIndex = xlNone
   
5.     i = Cells(Rows.Count, 1).End(xlUp).Row
   
6.     j = Cells(1, Columns.Count).End(xlToLeft).Column
   
7.     arr = Range(Cells(1, 1), Cells(i, j))
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     Set d2 = CreateObject("scripting.dictionary")
   
10.     For i = 1 To UBound(arr)
    
11.         d1.RemoveAll
    
12.         d2.RemoveAll
    
13.         For x = (j + 1) / 3 + 1 To (j + 1) * 2 / 3 - 1
    
14.             d1(arr(i, x)) = ""
    
15.         Next
    
16.         For x = (j + 1) * 2 / 3 + 1 To UBound(arr, 2)
    
17.             d2(arr(i, x)) = ""
    
18.         Next
    
19.         For x = 1 To (j + 1) / 3 - 1
    
20.             If d1.exists(arr(i, x)) And d2.exists(arr(i, x)) Then
    
21.                 Cells(i, x).Interior.ColorIndex = 6
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     Set d1 = Nothing
    
26.     Set d2 = Nothing
    
27. End Sub

复制代码