[已解决]如果用VBA，进行对比，找出不同的地方，谢谢。

新一

如果用VBA，进行对比，找出不同的地方，谢谢。如附件中，表一与表二进行对比，结果在表三中显示出来，满足两个条件：日期+姓名，找出总计加班列的不相同的地方。表三结果为模拟结果，谢谢。

最佳答案

月排行榜 / 总排行榜

dsmch

2015-7-31 23:17

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. n = 1: Sheet3.Activate
   
5. [a:g].Clear
   
6. For i = 1 To 2
   
7.     Sheets(i).Range("a1").CurrentRegion.Offset(i - 1, 0).Copy Cells(n, 1)
   
8.     n = Range("a65536").End(xlUp).Row + 1
   
9. Next
   
10. arr = Range("a1").CurrentRegion
    
11. ReDim brr(1 To UBound(arr), 1 To 1)
    
12. For i = 2 To UBound(arr)
    
13.     zf = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 5)
    
14.     If Not d.exists(zf) Then
    
15.         d(zf) = i
    
16.     Else
    
17.         brr(d(zf), 1) = 1
    
18.         brr(i, 1) = 1
    
19.     End If
    
20. Next
    
21. With Range("g1").Resize(UBound(brr))
    
22.     .Value = brr
    
23.     .SpecialCells(xlCellTypeConstants, 23).EntireRow.Delete
    
24. End With
    
25. Range("a1").CurrentRegion.Sort [a2], Header:=xlGuess
    
26. End Sub

复制代码

跳转到最佳答案楼层

上清宫主

用了字典，请自行引用（方法请参考相关资料）
Sub test()
Dim d As New Dictionary, ar1(), ar2(), ar3()
ar1 = Sheets("表一").Range("a1").CurrentRegion.Value
ar2 = Sheets("表二").Range("a1").CurrentRegion.Value
ReDim ar3(1 To UBound(ar1) + UBound(ar2), 1 To 6)
For i1% = 2 To UBound(ar1)
    d(ar1(i1, 1) & "|" & ar1(i1, 2) & "|" & ar1(i1, 5)) = 1
Next
For i1% = 2 To UBound(ar2)
    If d.Exists(ar2(i1, 1) & "|" & ar2(i1, 2) & "|" & ar2(i1, 5)) Then
        d(ar2(i1, 1) & "|" & ar2(i1, 2) & "|" & ar2(i1, 5)) = 2
    Else
        i2 = i2% + 1
        For i3 = 1 To 6
            ar3(i2, i3) = ar2(i1, i3)
        Next
    End If
Next
For i1% = 2 To UBound(ar1)
    If d(ar1(i1, 1) & "|" & ar1(i1, 2) & "|" & ar1(i1, 5)) = 1 Then
        i2 = i2% + 1
        For i3 = 1 To 6
            ar3(i2, i3) = ar1(i1, i3)
        Next
    End If
Next
Sheets("表三").Range("a2").Resize(i2, 6) = ar3
End Sub

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. n = 1: Sheet3.Activate
   
5. [a:g].Clear
   
6. For i = 1 To 2
   
7.     Sheets(i).Range("a1").CurrentRegion.Offset(i - 1, 0).Copy Cells(n, 1)
   
8.     n = Range("a65536").End(xlUp).Row + 1
   
9. Next
   
10. arr = Range("a1").CurrentRegion
    
11. ReDim brr(1 To UBound(arr), 1 To 1)
    
12. For i = 2 To UBound(arr)
    
13.     zf = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 5)
    
14.     If Not d.exists(zf) Then
    
15.         d(zf) = i
    
16.     Else
    
17.         brr(d(zf), 1) = 1
    
18.         brr(i, 1) = 1
    
19.     End If
    
20. Next
    
21. With Range("g1").Resize(UBound(brr))
    
22.     .Value = brr
    
23.     .SpecialCells(xlCellTypeConstants, 23).EntireRow.Delete
    
24. End With
    
25. Range("a1").CurrentRegion.Sort [a2], Header:=xlGuess
    
26. End Sub

复制代码

新一

谢谢，各位大神的帮助。{:011:}