[已解决]用代码方法查找两个工作表中相同和不相同的数据并在另外工作表列出

shixyi37

如题，请教大师们编代码，因为我想用宏方法的，麻烦了，先谢谢。附件中《期中》、《期末》工作表为数据源，其他表为查找后列出结果

查找并列出相同不相同.zip (9.6 KB, 下载次数: 30)

2015-2-6 10:37 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2015-2-6 11:35

………………

跳转到最佳答案楼层

hwc2ycy

这个直接用函数就能解决呀。

hwc2ycy

不好意思，没细看题意，

shixyi37

hwc2ycy 发表于 2015-2-6 10:46
这个直接用函数就能解决呀。

我就是想用宏的啊

hwc2ycy

1. Sub demo()
   
2.     Dim arrQz, arrQm
   
3.     Dim dicQz As Object, dicQm As Object
   
4.     Dim arrPos(1 To 3) As Long
   
5. 
   
6.     '取期中，期末数据
   
7.     '    arrQz = Worksheets("期中").UsedRange.Value
   
8.     '    arrQm = Worksheets("期末").UsedRange.Value
   
9.     With Worksheets("期中")
   
10.         arrQz = .Range("a3:e" & .Cells(Rows.Count, 1).End(xlUp).Row)
    
11.     End With
    
12.     With Worksheets("期末")
    
13.         arrQm = .Range("a3:e" & .Cells(Rows.Count, 1).End(xlUp).Row)
    
14.     End With
    
15. 
    
16.     '字典,存储学号与数据所在的行号
    
17.     Set dicQz = CreateObject("scripting.dictionary")
    
18.     Set dicQm = CreateObject("scripting.dictionary")
    
19.     Dim i&
    
20.     '结果数组
    
21.     Dim arrQzQm1(1 To 500, 1 To 5), arrQzQm2(1 To 500, 1 To 5), arrQzonly(1 To 500, 1 To 5), arrQmonly(1 To 500, 1 To 5)
    
22. 
    
23.     '存储相关数据到对应的字典中
    
24.     For i = LBound(arrQz) To UBound(arrQz)
    
25.         dicQz(arrQz(i, 1)) = i
    
26.     Next
    
27.     For i = LBound(arrQm) To UBound(arrQm)
    
28.         dicQm(arrQm(i, 1)) = i
    
29.     Next
    
30. 
    
31. 
    
32.     Dim Keytmp, j&, k&, l&, m&
    
33.     '遍历期中字典
    
34.     For Each Keytmp In dicQz.keys
    
35.         If dicQm.Exists(Keytmp) Then
    
36.             '期中期末共有数据
    
37.             arrPos(1) = arrPos(1) + 1
    
38.             k = arrPos(1)    '结果数组行号
    
39.             l = dicQz(Keytmp)    '期中数据行号
    
40.             m = dicQz(Keytmp)    '期末数据行号
    
41.             For j = LBound(arrQz, 2) To UBound(arrQz, 2)
    
42.                 arrQzQm1(k, j) = arrQz(l, j)    '期中
    
43.                 arrQzQm2(k, j) = arrQm(m, j)    '期末
    
44.             Next
    
45.             dicQm.Remove (Keytmp)    '删除期末共有的
    
46.         Else
    
47.             '期中独有
    
48.             arrPos(2) = arrPos(2) + 1
    
49.             k = arrPos(2)    '结果数组行号
    
50.             l = dicQz(Keytmp)    '期中数据行号
    
51.             For j = LBound(arrQz, 2) To UBound(arrQz, 2)
    
52.                 arrQzonly(k, j) = arrQz(l, j)    '期中
    
53.             Next
    
54.         End If
    
55.     Next
    
56.     If dicQm.Count Then
    
57.         '期末独有
    
58.         For Each Keytmp In dicQm.keys
    
59.             arrPos(3) = arrPos(3) + 1
    
60.             k = arrPos(3)    '结果数组行号
    
61.             l = dicQm(Keytmp)    '期末数据行号
    
62.             For j = LBound(arrQm, 2) To UBound(arrQm, 2)
    
63.                 arrQmonly(k, j) = arrQm(l, j)    '期末
    
64.             Next
    
65.         Next
    
66.     End If
    
67.     Application.ScreenUpdating = False
    
68.     With Worksheets("期中期末共有")
    
69.         .Range("a4").Resize(UBound(arrQzQm1), UBound(arrQzQm1, 2)).Value = arrQzQm1
    
70.         .Range("g4").Resize(UBound(arrQzQm2), UBound(arrQzQm2, 2)).Value = arrQzQm2
    
71.     End With
    
72.     Worksheets("期中有期末没有").Range("a4").Resize(UBound(arrQzonly), UBound(arrQzonly, 2)).Value = arrQzonly
    
73.     Worksheets("期末有期中没有").Range("a4").Resize(UBound(arrQmonly), UBound(arrQmonly, 2)).Value = arrQmonly
    
74.     Application.ScreenUpdating = True
    
75.     MsgBox "对比完成", vbInformation
    
76. End Sub
    

复制代码

hwc2ycy

上面的有个数组名错了，更正

1. Option Explicit
   
2. 
   
3. Sub demo()
   
4.     Dim arrQz, arrQm
   
5.     Dim dicQz As Object, dicQm As Object
   
6.     Dim arrPos(1 To 3) As Long
   
7. 
   
8.     '取期中，期末数据
   
9.     '    arrQz = Worksheets("期中").UsedRange.Value
   
10.     '    arrQm = Worksheets("期末").UsedRange.Value
    
11.     With Worksheets("期中")
    
12.         arrQz = .Range("a3:e" & .Cells(Rows.Count, 1).End(xlUp).Row)
    
13.     End With
    
14.     With Worksheets("期末")
    
15.         arrQm = .Range("a3:e" & .Cells(Rows.Count, 1).End(xlUp).Row)
    
16.     End With
    
17. 
    
18.     '字典,存储学号与数据所在的行号
    
19.     Set dicQz = CreateObject("scripting.dictionary")
    
20.     Set dicQm = CreateObject("scripting.dictionary")
    
21.     Dim i&
    
22.     '结果数组
    
23.     Dim arrQzQm1(1 To 500, 1 To 5), arrQzQm2(1 To 500, 1 To 5), arrQzonly(1 To 500, 1 To 5), arrQmonly(1 To 500, 1 To 5)
    
24. 
    
25.     '存储相关数据到对应的字典中
    
26.     For i = LBound(arrQz) To UBound(arrQz)
    
27.         dicQz(arrQz(i, 1)) = i
    
28.     Next
    
29.     For i = LBound(arrQm) To UBound(arrQm)
    
30.         dicQm(arrQm(i, 1)) = i
    
31.     Next
    
32. 
    
33. 
    
34.     Dim Keytmp, j&, k&, l&, m&
    
35.     '遍历期中字典
    
36.     For Each Keytmp In dicQz.keys
    
37.         If dicQm.Exists(Keytmp) Then
    
38.             '期中期末共有数据
    
39.             arrPos(1) = arrPos(1) + 1
    
40.             k = arrPos(1)    '结果数组行号
    
41.             l = dicQz(Keytmp)    '期中数据行号
    
42.             m = dicQm(Keytmp)    '期末数据行号
    
43.             For j = LBound(arrQz, 2) To UBound(arrQz, 2)
    
44.                 arrQzQm1(k, j) = arrQz(l, j)    '期中
    
45.                 arrQzQm2(k, j) = arrQm(m, j)    '期末
    
46.             Next
    
47.             dicQm.Remove (Keytmp)    '删除期末共有的
    
48.         Else
    
49.             '期中独有
    
50.             arrPos(2) = arrPos(2) + 1
    
51.             k = arrPos(2)    '结果数组行号
    
52.             l = dicQz(Keytmp)    '期中数据行号
    
53.             For j = LBound(arrQz, 2) To UBound(arrQz, 2)
    
54.                 arrQzonly(k, j) = arrQz(l, j)    '期中
    
55.             Next
    
56.         End If
    
57.     Next
    
58.     If dicQm.Count Then
    
59.         '期末独有
    
60.         For Each Keytmp In dicQm.keys
    
61.             arrPos(3) = arrPos(3) + 1
    
62.             k = arrPos(3)    '结果数组行号
    
63.             l = dicQm(Keytmp)    '期末数据行号
    
64.             For j = LBound(arrQm, 2) To UBound(arrQm, 2)
    
65.                 arrQmonly(k, j) = arrQm(l, j)    '期末
    
66.             Next
    
67.         Next
    
68.     End If
    
69.     Application.ScreenUpdating = False
    
70.     With Worksheets("期中期末共有")
    
71.         .Range("a4").Resize(UBound(arrQzQm1), UBound(arrQzQm1, 2)).Value = arrQzQm1
    
72.         .Range("g4").Resize(UBound(arrQzQm2), UBound(arrQzQm2, 2)).Value = arrQzQm2
    
73.     End With
    
74.     Worksheets("期中有期末没有").Range("a4").Resize(UBound(arrQzonly), UBound(arrQzonly, 2)).Value = arrQzonly
    
75.     Worksheets("期末有期中没有").Range("a4").Resize(UBound(arrQmonly), UBound(arrQmonly, 2)).Value = arrQmonly
    
76.     Application.ScreenUpdating = True
    
77.     MsgBox "对比完成", vbInformation
    
78. End Sub
    

复制代码

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr, d, ar, dr, cr, i&, j%, s1&, s2&, s3&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheets("期中").Range("a1").CurrentRegion
   
6. brr = Sheets("期末").Range("a1").CurrentRegion
   
7. ReDim ar(1 To UBound(arr), 1 To UBound(arr, 2) * 2 + 1)
   
8. ReDim br(1 To UBound(arr), 1 To UBound(arr, 2))
   
9. ReDim cr(1 To UBound(brr), 1 To UBound(brr, 2))
   
10. For i = 3 To UBound(arr)
    
11.     d(arr(i, 1)) = i
    
12. Next
    
13. For i = 3 To UBound(brr)
    
14.     If Not d.exists(brr(i, 1)) Then
    
15.         s3 = s3 + 1
    
16.         For j = 1 To UBound(brr, 2)
    
17.             cr(s3, j) = brr(i, j)
    
18.         Next
    
19.         d(brr(i, 1)) = "," & i
    
20.     Else
    
21.         s1 = s1 + 1
    
22.         n = d(brr(i, 1))
    
23.         For j = 1 To UBound(arr)
    
24.             ar(s1, j) = arr(n, j)
    
25.             ar(s1, j + 6) = brr(i, j)
    
26.         Next
    
27.         d(brr(i, 1)) = d(brr(i, 1)) & "," & i
    
28.     End If
    
29. Next
    
30. b = d.items
    
31. For i = 0 To d.Count - 1
    
32.     If InStr(b(i), ",") = 0 Then
    
33.         s2 = s2 + 1
    
34.         For j = 1 To UBound(arr, 2)
    
35.         br(s2, j) = arr(b(i), j)
    
36.     Next
    
37. End If
    
38. Next
    
39. Sheet1.Range("a4").Resize(s1, UBound(ar, 2)) = ar
    
40. Sheet2.Range("a4").Resize(s2, UBound(br, 2)) = br
    
41. Sheet3.Range("a4").Resize(s3, UBound(cr, 2)) = cr
    
42. End Sub

复制代码

dsmch

………………

shixyi37

6楼 7楼的都能解决问题，非常感谢，太强大了