Option Explicit
Private Sub WorkSheet_Change(ByVal Target As Range)
If Not Intersect(Range("B3:E10000", "H3:K10000"), Target) Is Nothing Then
Application.ScreenUpdating = False
UpdateB3
End If
End Sub
Private Sub UpdateB3()
Dim N1 As Integer, N2 As Integer, N As Integer, i As Integer, j As Integer, k As Integer, i3 As Integer, Dem As Integer
Dim Rgn1 As Range, Rgn2 As Range, aCo() As Byte: Dim Item_i, Order_i, Item_j, Order_j
Range("M3", Range("Q10000").End(xlUp).Address).ClearContents
N1 = Range("B10000").End(xlUp).Row - 3 + 1: N2 = Range("H10000").End(xlUp).Row - 3 + 1: N = N1 + N2
ReDim aCo(N): For i = 1 To N: aCo(i) = 0: Next i
Set Rgn1 = Range("A3", Range("A3").Offset(N1 - 1, 4).Address)
Set Rgn2 = Range("G3", Range("G3").Offset(N2 - 1, 4).Address)
i3 = 0: Dem = 0
For i = 1 To N
If aCo(i) = 0 Then
aCo(i) = 1: k = i: Dem = Dem + 1
If i <= N1 Then
Item_i = Rgn1(i, 2): Order_i = Rgn1(i, 3)
Else: Item_i = Rgn2(i - N1, 2): Order_i = Rgn2(i - N1, 3): End If
For j = i + 1 To N
If aCo(j) = 0 Then
If j <= N1 Then
Item_j = Rgn1(j, 2): Order_j = Rgn1(j, 3)
Else: Item_j = Rgn2(j - N1, 2): Order_j = Rgn2(j - N1, 3): End If
If Item_i = Item_j And Order_i = Order_j Then: aCo(j) = 1: k = j: Dem = Dem + 1
End If
Next j
i3 = i3 + 1: Range("M3").Offset(i3 - 1, 0).Value = i3
With Range(Range("M3").Offset(i3 - 1, 1).Address, Range("M3").Offset(i3 - 1, 4).Address)
If k <= N1 Then
.Value = Range(Rgn1(k, 2).Address, Rgn1(k, 5).Address).Value
Else: .Value = Range(Rgn2(k - N1, 2).Address, Rgn2(k - N1, 5).Address).Value: End If
End With
End If
If Dem = N Then Exit For
Next i
End Sub
