[求助]将两个Excel中的数据进行对比的方法？

bajifeng

完全按照你给的表1、表2 的数据，按照表3模板的格式做的。

bajifeng

要想得到最准确的代码，要么传原始表格，不方便传原始数据的话，还是需要真的模拟数据，这样才方便大家帮你解决问题。

bajifeng

发现你的表3数据并不是按照 表1、表2 的数据模拟出来的结果，而是随意表示了一下效果。
不过，这没关系，我能领会您的意思。

bajifeng

>>>>>>>>>>>
动画演示

bajifeng

1. Sub bajifeng()  'by: bajifeng
   
2. 'Thursday, December 20, 2015
   
3. 'http://club.excelhome.net/thread-1247813-1-1.html
   
4. Dim crr()
   
5. [a2:d200].Clear
   
6. fn = Array("1.xls", "2.xls")
   
7. Workbooks.Open ThisWorkbook.Path & "" & fn(0)
   
8. arr = ActiveSheet.UsedRange
   
9. ActiveWorkbook.Close False
   
10. Workbooks.Open ThisWorkbook.Path & "" & fn(1)
    
11. brr = ActiveSheet.UsedRange
    
12. ActiveWorkbook.Close False
    
13. Set d = CreateObject("scripting.dictionary")
    
14. Set d1 = CreateObject("scripting.dictionary")
    
15. Set d2 = CreateObject("scripting.dictionary")
    
16. 
    
17. For i = 3 To UBound(arr)
    
18.     If InStr(arr(i, 2), "Address") = 0 Then
    
19.         d1(arr(i, 2)) = arr(i, 6)
    
20.         'Debug.Print f
    
21.         d(arr(i, 2)) = ""
    
22.     End If
    
23. Next
    
24. k1 = d1.keys
    
25. t1 = d1.items
    
26. 
    
27. For i = 3 To UBound(brr)
    
28.     If InStr(arr(i, 2), "Address") = 0 Then
    
29.         d2(brr(i, 2)) = brr(i, 6)
    
30.         d(brr(i, 2)) = ""
    
31.     End If
    
32. Next
    
33. k2 = d2.keys
    
34. t2 = d2.items
    
35. k = d.keys
    
36. 
    
37. ReDim crr(1 To d.Count, 1 To 4)
    
38. For i = 0 To d.Count - 1
    
39. 
    
40.     crr(i + 1, 1) = k(i)
    
41.     '1
    
42.     For i1 = 0 To d1.Count - 1
    
43.         If k(i1) = k(i) Then crr(i + 1, 2) = "'" & t1(i1)
    
44.     Next
    
45.     '2
    
46.     For i2 = 0 To d2.Count - 1
    
47.         If k(i2) = k(i) Then crr(i + 1, 3) = "'" & t2(i2)
    
48.     Next
    
49.     '对比结果
    
50.     If crr(i + 1, 2) = crr(i + 1, 3) And crr(i + 1, 2) <> "" Then
    
51.         crr(i + 1, 4) = "OK"
    
52.         Cells(i + 2, 4).Interior.ColorIndex = 4
    
53.     Else
    
54.         crr(i + 1, 4) = "NG"
    
55.         Cells(i + 2, 4).Interior.ColorIndex = 3
    
56.     End If
    
57. 
    
58. Next
    
59. [a2:d2].Resize(d.Count) = crr
    
60. End Sub

复制代码

bajifeng

>>>>>>>>>>>>>>>>>>>>>>>

bajifeng

>>>>>>>>>>>>>>>>>>
加了背景颜色区分：

解0人

1. '提取1.xls数据，B列为address，C列为Size，F为data
   
2. Function dataDict1(rng As Range)
   
3. Dim d, a, i%
   
4.     a = rng
   
5.     Set d = CreateObject("Scripting.dictionary")
   
6.     For i = 3 To UBound(a)  '从第3行开始
   
7.         If IsNumeric(a(i, 2)) Then
   
8.             For j = 0 To a(i, 2) - 1
   
9.                 d(Right(Hex(Val("&H" & Right(a(i, 1), 4)) + j), 4)) = "'" & Mid(a(i, 5), j * 2 + 1, 2)
   
10.             Next
    
11.         End If
    
12.     Next
    
13.     Set dataDict1 = d
    
14. End Function
    
15. '提取2.xls数据，B列为address，D列为Size，G为data
    
16. Function dataDict2(rng As Range)
    
17. Dim d, a, i%
    
18.     a = rng
    
19.     Set d = CreateObject("Scripting.dictionary")
    
20.     For i = 3 To UBound(a)  '从第3行开始
    
21.         If IsNumeric(a(i, 3)) Then
    
22.             For j = 0 To a(i, 3) - 1
    
23.                 d(Right(Hex(Val("&H" & Right(a(i, 1), 4)) + j), 4)) = "'" & IIf(a(i, 6) Like "N/A*", a(i, 6), Mid(a(i, 6), j * 2 + 1, 2))
    
24.             Next
    
25.         End If
    
26.     Next
    
27.     Set dataDict2 = d
    
28. End Function
    
29. '
    
30. Sub test()
    
31. Dim d1, d2, wb, wb1, wb2, a1, a2, i%
    
32.     '如果1.xls，2.xls已经打开则直接提取数据，否则先打开再提取数据
    
33.     For Each wb In Workbooks
    
34.         If wb.Name = "1.xls" Then
    
35.             Set wb1 = wb
    
36.         ElseIf wb.Name = "2.xls" Then
    
37.             Set wb2 = wb
    
38.         End If
    
39.     Next
    
40.    
    
41.     '1.xls和2.xls应该和3.xls在同一路径
    
42.     If IsEmpty(wb1) Then Set wb1 = Workbooks.Open(ThisWorkbook.Path & "\1.xls")
    
43.     If IsEmpty(wb2) Then Set wb2 = Workbooks.Open(ThisWorkbook.Path & "\2.xls")
    
44.     '数据都在1.xls和2.xls的第一个工作表
    
45.     Set d1 = dataDict1(Application.Intersect(wb1.Sheets(1).UsedRange, wb1.Sheets(1).Columns("B:F")))
    
46.     Set d2 = dataDict2(Application.Intersect(wb2.Sheets(1).UsedRange, wb2.Sheets(1).Columns("B:G")))
    
47.    
    
48.     With Sheet2
    
49.         '填充
    
50.         .[a2].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
    
51.         .[B2].Resize(d1.Count, 1) = Application.Transpose(d1.items)
    
52. '        .[E2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)
    
53.         .[C2].Resize(d2.Count, 1) = Application.Transpose(d2.items)
    
54.         '对比
    
55.         a1 = .[B2].Resize(d1.Count, 2)
    
56.         ReDim a2(UBound(a1))
    
57.         For i = 1 To UBound(a1)
    
58.             If a1(i, 1) = a1(i, 2) Then
    
59.                 a2(i - 1) = "OK"
    
60.             Else
    
61.                 a2(i - 1) = "NG"
    
62.             End If
    
63.         Next
    
64.         .[d2].Resize(UBound(a1), 1) = Application.Transpose(a2)
    
65.         .Activate
    
66.     End With
    
67. End Sub
    

复制代码

解0人

代码在3.xls中的【对比】表中，
注意：
看你图片中
1.xls，B列为address，C列为Size，F为data
2.xls，B列为address，D列为Size，G为data
以上B、C、F和B、D、G都是必要的
但是，你的实际数据实例格式和上面不符，
为了统一，我修改了你的1.xls和2.xls格式
具体请看对应xls文件。

↓↓↓↓↓↓↓↓↓↓↓↓

znevq

解0人 发表于 2015-12-20 22:33
代码在3.xls中的【对比】表中，
注意：
看你图片中

谢谢老师，辛苦你了！