请教一个两表对比问题。。。。。

jiminyanyan

请教一个两表对比问题。。。。。

最美夕阳红

没明白老师的意思

jiminyanyan

最美夕阳红 发表于 2014-8-5 14:38
没明白老师的意思

姓名 学号  金额 如两表中都有且一样，则把两表中的该行都删除，留下不一样的。。。。。

魂断蓝桥

先排序，再对比？

jiminyanyan

魂断蓝桥 发表于 2014-8-5 14:47
先排序，再对比？

最好不要改变顺序。。。。

yaozong

jiminyanyan 发表于 2014-8-5 16:44
最好不要改变顺序。。。。

1. Sub yy()
   
2.   Sheet1.Activate
   
3.   Dim dx, dy, arr, brr, x, y, s, t, i&, j&, m&, n&
   
4.   Set dx = CreateObject("Scripting.Dictionary")
   
5.   Set dy = CreateObject("Scripting.Dictionary")
   
6.   arr = Range("a4:c" & [a65536].End(3).Row).Value
   
7.   brr = Range("e4:g" & [e65536].End(3).Row).Value
   
8.   For i = 1 To UBound(arr)
   
9.     t = Application.Index(arr, i, 0)
   
10.     s = Join(t, ",")
    
11.     dx(s) = dx(s) + 1
    
12.   Next
    
13.   For i = 1 To UBound(brr)
    
14.     t = Application.Index(brr, i, 0)
    
15.     s = Join(t, ",")
    
16.     dx(s) = dx(s) - 1
    
17.     dy(s) = dy(s) + 1
    
18.   Next
    
19.   For i = 1 To UBound(arr)
    
20.     t = Application.Index(arr, i, 0)
    
21.     s = Join(t, ",")
    
22.     dy(s) = dy(s) - 1
    
23.   Next
    
24.   For Each x In dx.keys
    
25.     If dx(x) < 1 Then
    
26.       dx.Remove (x)
    
27.     Else
    
28.       For j = 1 To dx(x)
    
29.          m = m + 1
    
30.          arr(m, 1) = Split(x, ",")(0)
    
31.          arr(m, 2) = Split(x, ",")(1)
    
32.          arr(m, 3) = Split(x, ",")(2)
    
33.       Next
    
34.     End If
    
35.   Next
    
36.   For Each y In dy.keys
    
37.     If dy(y) < 1 Then
    
38.       dy.Remove (y)
    
39.     Else
    
40.       For j = 1 To dy(y)
    
41.          n = n + 1
    
42.          brr(n, 1) = Split(y, ",")(0)
    
43.          brr(n, 2) = Split(y, ",")(1)
    
44.          brr(n, 3) = Split(y, ",")(2)
    
45.       Next
    
46.     End If
    
47.   Next
    
48.   If m > 0 Then [i6].Resize(m, 3) = arr
    
49.   If n > 0 Then [m6].Resize(n, 3) = brr
    
50.   Set dx = Nothing
    
51.   Set dy = Nothing
    
52. End Sub

复制代码

yaozong

测试附件            

lcjy11185

先做个记号，学习了

jiminyanyan

我也写了一个，供参考。。。。。

1. Sub yy1()
   
2.   Sheet1.Activate
   
3.   Dim arr1, brr1
   
4.   Dim dx, dy, arr(1 To 1000, 1 To 4), brr(1 To 1000, 1 To 4), crr(1 To 1000, 1 To 3), drr(1 To 1000, 1 To 3), x, y, s, t, i&, j&, m&, n&
   
5.   Set dx = CreateObject("Scripting.Dictionary")
   
6.   Set dy = CreateObject("Scripting.Dictionary")
   
7.   arr1 = Range("a4:c" & [a65536].End(3).Row).Value
   
8.   brr1 = Range("e4:g" & [e65536].End(3).Row).Value
   
9.   For i = 1 To UBound(arr1)
   
10.     arr(i, 1) = arr1(i, 1)
    
11.     arr(i, 2) = arr1(i, 2)
    
12.     arr(i, 3) = arr1(i, 3)
    
13.   Next
    
14.    For i = 1 To UBound(brr1)
    
15.     brr(i, 1) = brr1(i, 1)
    
16.     brr(i, 2) = brr1(i, 2)
    
17.     brr(i, 3) = brr1(i, 3)
    
18.   Next
    
19.   For i = 1 To UBound(arr)
    
20.     dx(arr(i, 1)) = dx(arr(i, 1)) + 1
    
21.     arr(i, 4) = dx(arr(i, 1))
    
22.     s = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4)
    
23.     dx(s) = ""
    
24.   Next
    
25.   For i = 1 To UBound(brr)
    
26.     dy(brr(i, 1)) = dy(brr(i, 1)) + 1
    
27.     brr(i, 4) = dy(brr(i, 1))
    
28.     s = brr(i, 1) & brr(i, 2) & brr(i, 3) & brr(i, 4)
    
29.     dy(s) = ""
    
30.   Next
    
31.   For i = 1 To UBound(arr)
    
32.     s = arr(i, 1) & arr(i, 2) & arr(i, 3) & arr(i, 4)
    
33.     If dy.exists(s) Then
    
34.     Else
    
35.         n = n + 1
    
36.         crr(n, 1) = arr(i, 1)
    
37.         crr(n, 2) = arr(i, 2)
    
38.         crr(n, 3) = arr(i, 3)
    
39.     End If
    
40.   Next
    
41.   For i = 1 To UBound(brr)
    
42.     s = brr(i, 1) & brr(i, 2) & brr(i, 3) & brr(i, 4)
    
43.     If dx.exists(s) Then
    
44.     Else
    
45.         m = m + 1
    
46.         drr(m, 1) = brr(i, 1)
    
47.         drr(m, 2) = brr(i, 2)
    
48.         drr(m, 3) = brr(i, 3)
    
49.     End If
    
50.   Next
    
51.   If m > 0 Then [i6].Resize(m, 3) = crr
    
52.   If n > 0 Then [m6].Resize(n, 3) = drr
    
53.   Set dx = Nothing
    
54.   Set dy = Nothing
    
55. End Sub
    

复制代码

jiminyanyan

。。。。。。。。。。