- Sub test()
- Dim arr, ar, d1 As Object, d2 As Object
- Dim x%, y%, s1$, s2$, j%, maxr%
- Set d1 = CreateObject("scripting.dictionary")
- Set d2 = CreateObject("scripting.dictionary")
- arr = Sheet1.UsedRange.Value
- ar = Sheet2.UsedRange.Value
- For x = 3 To UBound(arr)
- For y = 3 To UBound(ar)
- s1 = arr(x, 2) & arr(x, 6)
- s2 = ar(y, 2) & ar(y, 6)
- d1(s1) = 0: d2(s2) = 0
- If s1 = s2 Then
- For j = 3 To 5
- If arr(x, j) <> ar(y, j) Then
- With Sheet2
- .Cells(y, j) = Sheet1.Cells(x, j)
- .Cells(y, j).Interior.ColorIndex = 5
- .Cells(y, "h") = "修改了数据!"
- End With
- End If
- Next
- End If
- Next y
- Next x
- For x = 3 To UBound(arr)
- s1 = arr(x, 2) & arr(x, 6)
- If Not d2.exists(s1) Then
- With Sheet2
- maxr = .[a2].End(4).Row + 1
- Sheet1.Cells(x, 1).Resize(1, 7).Copy .Cells(maxr, 1)
- .Cells(maxr, "h") = "增加内容"
- .Cells(maxr, 1).Resize(1, 8).Interior.ColorIndex = 4
- End With
- End If
- Next x
- For y = 3 To UBound(ar)
- s2 = ar(y, 2) & ar(y, 6)
- If Not d1.exists(s2) Then
- With Sheet2
- .Cells(y, 1).Resize(1, 8).Interior.ColorIndex = 3
- .Cells(y, "h") = "删除内容!"
- End With
- End If
- Next y
- End Sub
复制代码 |