[已解决]比较相同的问题

Baibdu

附件 比较相同.rar (23.43 KB, 下载次数: 17)

2014-10-28 21:18 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2014-10-29 05:57

………………

跳转到最佳答案楼层

Excel学徒123

建议采用代码，虽然遍历单元格会比较卡，出现假死的状态

1. Sub 比较数据()
   
2.     Dim rg As Range, rg1 As Range
   
3.         For Each rg In Sheets("Sheet1").UsedRange
   
4.             For Each rg1 In Sheets("Sheet2").UsedRange
   
5.                 If rg.Value <> "" And rg1.Value <> "" And rg = rg1 Then
   
6.                     rg.Cells.Interior.ColorIndex = 6
   
7.                 End If
   
8.             Next
   
9.         Next
   
10. End Sub
    

复制代码

Baibdu

Excel学徒123 发表于 2014-10-28 23:56
建议采用代码，虽然遍历单元格会比较卡，出现假死的状态

谢谢老师帮助。试了一下，估计您把题意理解错了。
执行代码后，循环着把无关联的单元格数据都标黄了。而且特慢。七百行数据执行完，估计没有一个小时结束不了。

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, d2, rng As Range
   
3. Dim i&, j%, zf$, rng2 As Range
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. arr = Range("a1").CurrentRegion
   
7. brr = Sheet2.Range("a1").CurrentRegion
   
8. For i = 1 To UBound(arr)
   
9.     For j = 1 To UBound(arr, 2)
   
10.         zf = i & "," & arr(i, j)
    
11.         d(zf) = ""
    
12.     Next
    
13. Next
    
14. For i = 1 To UBound(brr)
    
15.     For j = 1 To UBound(brr, 2)
    
16.         zf = i & "," & brr(i, j)
    
17.         d2(zf) = ""
    
18.         If d.exists(zf) And brr(i, j) <> "" Then
    
19.             If rng2 Is Nothing Then Set rng2 = Sheet2.Cells(i, j) Else Set rng2 = Union(rng2, Sheet2.Cells(i, j))
    
20.         End If
    
21.     Next
    
22. Next
    
23. For i = 1 To UBound(arr)
    
24.     For j = 1 To UBound(arr, 2)
    
25.         zf = i & "," & arr(i, j)
    
26.         If d2.exists(zf) And arr(i, j) <> "" Then
    
27.             If rng Is Nothing Then Set rng = Cells(i, j) Else Set rng = Union(rng, Cells(i, j))
    
28.         End If
    
29.     Next
    
30. Next
    
31. ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
    
32. Sheet2.UsedRange.Interior.ColorIndex = xlNone
    
33. If Not rng Is Nothing Then rng.Interior.ColorIndex = 6
    
34. If Not rng2 Is Nothing Then rng2.Interior.ColorIndex = 6
    
35. End Sub

复制代码

dsmch

………………