|
|
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 arr()
Dim rn1 As Range, rn2 As Range
With Sheets("数据组1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "数据组1为空！": End
ar = .Range("a1:m" & r)
End With
For i = 2 To UBound(ar)
If ar(i, 13) <> "" Then
d(ar(i, 13)) = i
End If
Next i
With Sheets("数据组2")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
If rs < 2 Then MsgBox "数据组2为空！": End
br = .Range("a1:m" & rs)
End With
ReDim arr(1 To UBound(ar) + UBound(br), 1 To UBound(ar, 2))
For i = 2 To UBound(br)
If br(i, 13) <> "" Then
xh = d(br(i, 13))
If xh <> "" Then
n = n + 2
For j = 1 To 13
arr(n - 1, j) = ar(xh, j)
arr(n, j) = br(i, j)
Next j
If rn1 Is Nothing Then
Set rn1 = Sheets("数据组1").Rows(xh)
Else
Set rn1 = Union(rn1, Sheets("数据组1").Rows(xh))
End If
If rn2 Is Nothing Then
Set rn2 = Sheets("数据组2").Rows(i)
Else
Set rn2 = Union(rn2, Sheets("数据组2").Rows(i))
End If
End If
End If
Next i
If n = "" Then MsgBox "没有匹配到数据！": End
With Sheets("配对成功")
.[a1].CurrentRegion.Offset(1) = Empty
.[a2].Resize(n, UBound(arr, 2)) = arr
End With
rn1.Delete
rn2.Delete
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-2-21 08:58
楼主
