[已解决]二表对比与合并

张雄友

二表对比与合并。

将《表一》与《表二》完全相同的行提取到《完全相同》
《表一》与《表二》合并去掉完全重复的行。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-4-28 19:58

1. Sub Macro1()
   
2. Dim arr, brr, crr, drr, d, d2, i&, s&, s2&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheets("表一").Range("b2").CurrentRegion
   
6. brr = Sheets("表二").Range("b2").CurrentRegion
   
7. ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
   
8. ReDim drr(1 To 60000, 1 To UBound(arr, 2))
   
9. For i = 2 To UBound(brr)
   
10.     zf = Join(Application.Index(brr, i, 0), ",")
    
11.     d(zf) = d(zf) + 1
    
12.     If Not d2.exists(zf) Then
    
13.         d2(zf) = ""
    
14.         s2 = s2 + 1
    
15.         For j = 1 To UBound(brr, 2)
    
16.             drr(s2, j) = brr(i, j)
    
17.         Next
    
18.     End If
    
19. Next
    
20. For i = 2 To UBound(arr)
    
21.     zf = Join(Application.Index(arr, i, 0), ",")
    
22.     If d.exists(zf) And d(zf) > 0 Then
    
23.         d(zf) = d(zf) - 1
    
24.         s = s + 1
    
25.         For j = 1 To UBound(arr, 2)
    
26.             crr(s, j) = arr(i, j)
    
27.         Next
    
28.     End If
    
29.     If Not d2.exists(zf) Then
    
30.         d2(zf) = ""
    
31.         s2 = s2 + 1
    
32.         For j = 1 To UBound(arr, 2)
    
33.             drr(s2, j) = arr(i, j)
    
34.         Next
    
35.     End If
    
36. Next
    
37. Sheet3.Range("a2").Resize(s, UBound(crr, 2)) = crr
    
38. Sheet4.Range("a2").Resize(s2, UBound(drr, 2)) = drr
    
39. End Sub
    

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, drr, d, d2, i&, s&, s2&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. arr = Sheets("表一").Range("b2").CurrentRegion
   
6. brr = Sheets("表二").Range("b2").CurrentRegion
   
7. ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
   
8. ReDim drr(1 To 60000, 1 To UBound(arr, 2))
   
9. For i = 2 To UBound(brr)
   
10.     zf = Join(Application.Index(brr, i, 0), ",")
    
11.     d(zf) = d(zf) + 1
    
12.     If Not d2.exists(zf) Then
    
13.         d2(zf) = ""
    
14.         s2 = s2 + 1
    
15.         For j = 1 To UBound(brr, 2)
    
16.             drr(s2, j) = brr(i, j)
    
17.         Next
    
18.     End If
    
19. Next
    
20. For i = 2 To UBound(arr)
    
21.     zf = Join(Application.Index(arr, i, 0), ",")
    
22.     If d.exists(zf) And d(zf) > 0 Then
    
23.         d(zf) = d(zf) - 1
    
24.         s = s + 1
    
25.         For j = 1 To UBound(arr, 2)
    
26.             crr(s, j) = arr(i, j)
    
27.         Next
    
28.     End If
    
29.     If Not d2.exists(zf) Then
    
30.         d2(zf) = ""
    
31.         s2 = s2 + 1
    
32.         For j = 1 To UBound(arr, 2)
    
33.             drr(s2, j) = arr(i, j)
    
34.         Next
    
35.     End If
    
36. Next
    
37. Sheet3.Range("a2").Resize(s, UBound(crr, 2)) = crr
    
38. Sheet4.Range("a2").Resize(s2, UBound(drr, 2)) = drr
    
39. End Sub
    

复制代码

张雄友

dsmch 发表于 2014-4-28 19:58

有没有办法把表头一起搞过去？

张雄友

dsmch 发表于 2014-4-28 19:58

如果表一3行完全相同的，表二有5行完全相同的，应是什么结果？

对，如果每个工作表有二行以上相同的话代码就不适用了。

张雄友

dsmch 发表于 2014-4-28 19:58

如果每个表又有相同的话，
完全相同的只要一行就OK了。

dsmch

11行代码修改为
d(zf)=1