|
|
Sub 数据比对()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Dim br1(), br2(), br3()
With ActiveSheet
r = .Cells(Rows.Count, 2).End(xlUp).Row
ar = .Range("a1:c" & r)
rs = .Cells(Rows.Count, 6).End(xlUp).Row
br = .Range("e1:g" & rs)
ReDim br1(1 To UBound(ar), 1 To UBound(ar, 2))
ReDim br2(1 To UBound(br), 1 To UBound(br, 2))
ReDim br3(1 To UBound(br) + UBound(ar), 1 To UBound(br, 2))
For i = 3 To UBound(ar)
If Trim(ar(i, 2)) <> "" And Trim(ar(i, 3)) <> "" Then
zf = Trim(ar(i, 2)) & "|" & Trim(ar(i, 3))
d(zf) = i
End If
Next i
For i = 3 To UBound(br)
If Trim(br(i, 2)) <> "" And Trim(br(i, 3)) <> "" Then
zf = Trim(br(i, 2)) & "|" & Trim(br(i, 3))
If d.exists(zf) Then
n3 = n3 + 1
For j = 1 To UBound(br, 2)
br3(n3, j) = br(i, j)
Next j '''两个表都有的
Else
n2 = n2 + 1
For j = 1 To UBound(br, 2)
br2(n2, j) = br(i, j)
Next j '''新表有而原表无
End If
dc(zf) = i
End If
Next i
For i = 3 To UBound(ar)
If Trim(ar(i, 2)) <> "" And Trim(ar(i, 3)) <> "" Then
zf = Trim(ar(i, 2)) & "|" & Trim(ar(i, 3))
If Not dc.exists(zf) Then
n1 = n1 + 1
For j = 1 To UBound(ar, 2)
br1(n1, j) = ar(i, j)
Next j '''原表有而新表无
End If
End If
Next i
.UsedRange.Offset(2, 8) = Empty
If n1 <> "" Then
.[i3].Resize(n1, UBound(br1, 2)) = br1
End If
If n2 <> "" Then
.[m3].Resize(n2, UBound(br2, 2)) = br2
End If
If n3 <> "" Then
.[q3].Resize(n3, UBound(br3, 2)) = br3
End If
End With
MsgBox "ok!"
End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2022-12-7 10:02
楼主
