[已解决]两个工作表的数据比对

cunfu2010

表1与表2比对。如何实现：表1与表2所有完全相同的数据行自动将字体变成白色（即实现隐藏效果）并隐藏行，剩下两表比对后数据有差异的（比如说表2比表1多出来的1人的记录，或者同一人的某项社保数据有出入）记录行，用红色标记出来的。

最佳答案

月排行榜 / 总排行榜

dsmch

2016-5-13 09:30

1. Sub Macro1()
   
2. Dim arr, brr, ar, d, d2, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. brr = Sheet2.Range("a1").CurrentRegion
   
7. ReDim ar(1 To UBound(arr))
   
8. For i = 2 To UBound(arr)
   
9.     p = ""
   
10.     For j = 1 To UBound(arr, 2)
    
11.         p = p & "," & arr(i, j)
    
12.     Next
    
13.     ar(i) = p
    
14.     d(p) = i
    
15. Next
    
16. Application.ScreenUpdating = False
    
17. For i = 2 To UBound(brr)
    
18.     p = ""
    
19.     For j = 1 To UBound(brr, 2)
    
20.         p = p & "," & brr(i, j)
    
21.     Next
    
22.     d2(p) = i
    
23.     If Not d.Exists(p) Then
    
24.         Sheet2.Cells(i, 1).Resize(1, UBound(brr, 2)).Font.ColorIndex = 3
    
25.     Else
    
26.         Sheet2.Rows(i).Hidden = True
    
27.     End If
    
28. Next
    
29. For i = 2 To UBound(ar)
    
30.     If Not d2.Exists(ar(i)) Then
    
31.         Sheet1.Cells(i, 1).Resize(1, UBound(arr, 2)).Font.ColorIndex = 3
    
32.     Else
    
33.         Sheet1.Rows(i).Hidden = True
    
34.     End If
    
35. Next
    
36. Application.ScreenUpdating = True
    
37. End Sub

复制代码

跳转到最佳答案楼层

dsmch

仅用红色标记

1. Sub Macro1()
   
2. Dim arr, brr, ar, d, d2, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. brr = Sheet2.Range("a1").CurrentRegion
   
7. ReDim ar(1 To UBound(arr))
   
8. For i = 2 To UBound(arr)
   
9.     p = ""
   
10.     For j = 1 To UBound(arr, 2)
    
11.         p = p & "," & arr(i, j)
    
12.     Next
    
13.     ar(i) = p
    
14.     d(p) = i
    
15. Next
    
16. For i = 2 To UBound(brr)
    
17.     p = ""
    
18.     For j = 1 To UBound(brr, 2)
    
19.         p = p & "," & brr(i, j)
    
20.     Next
    
21.     d2(p) = i
    
22.    If Not d.Exists(p) Then Sheet2.Cells(i, 1).Font.ColorIndex = 3
    
23. Next
    
24. For i = 2 To UBound(ar)
    
25.     If Not d2.Exists(ar(i)) Then Sheet1.Cells(i, 1).Font.ColorIndex = 3
    
26. Next
    
27. End Sub

复制代码

cunfu2010

dsmch 发表于 2016-5-13 05:17
仅用红色标记

谢谢，标不是一个单元格，而是对应的整个行的非空单元格，并隐藏？

cunfu2010

dsmch 发表于 2016-5-13 05:17
仅用红色标记

谢谢，标红的目标实现了，隐藏行还是不行

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, ar, d, d2, i&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheet1.Range("a1").CurrentRegion
   
6. brr = Sheet2.Range("a1").CurrentRegion
   
7. ReDim ar(1 To UBound(arr))
   
8. For i = 2 To UBound(arr)
   
9.     p = ""
   
10.     For j = 1 To UBound(arr, 2)
    
11.         p = p & "," & arr(i, j)
    
12.     Next
    
13.     ar(i) = p
    
14.     d(p) = i
    
15. Next
    
16. Application.ScreenUpdating = False
    
17. For i = 2 To UBound(brr)
    
18.     p = ""
    
19.     For j = 1 To UBound(brr, 2)
    
20.         p = p & "," & brr(i, j)
    
21.     Next
    
22.     d2(p) = i
    
23.     If Not d.Exists(p) Then
    
24.         Sheet2.Cells(i, 1).Resize(1, UBound(brr, 2)).Font.ColorIndex = 3
    
25.     Else
    
26.         Sheet2.Rows(i).Hidden = True
    
27.     End If
    
28. Next
    
29. For i = 2 To UBound(ar)
    
30.     If Not d2.Exists(ar(i)) Then
    
31.         Sheet1.Cells(i, 1).Resize(1, UBound(arr, 2)).Font.ColorIndex = 3
    
32.     Else
    
33.         Sheet1.Rows(i).Hidden = True
    
34.     End If
    
35. Next
    
36. Application.ScreenUpdating = True
    
37. End Sub

复制代码

cunfu2010

dsmch 发表于 2016-5-13 09:30

谢谢，全部实现了。

乐乐2006201506

学习一下。

ZZCUEEI

学习一下谢谢

cunfu2010

dsmch 发表于 2016-5-13 09:30

你好，如果是比对相同的，如何修改代码？我琢磨了几天了，不得其法，再帮帮忙，谢谢！！！

cunfu2010

dsmch 发表于 2016-5-13 09:30

还是这个问题的附件，下面是你给出的比对差异的代码，非常棒，但如何改正比对重复的，即比对相同的，我琢磨了几天了，不行，麻烦你给看看，再发帖就是大同小异的帖子了。麻烦了，谢谢！！！