Here's an alternative using ranges an arrays.
Sub MG25Jul03
Dim Rng1 As Range
Dim Dn As Range
Dim Rng2 As Range
Dim Twn As String
Dim nRng As Range
Dim S As Byte
Dim n As Long
Dim nn As Long
Dim p As Long
Dim Ray
With Sheets("Price1")
Set Rng1 = .Range(.Range("B2"), .Range("B" & Rows.Count).End(xlUp))
End With
With Sheets("Price2")
Set Rng2 = .Range(.Range("B2"), .Range("B" & Rows.Count).End(xlUp))
End With
'Create Blank Results array
ReDim Ray(1 To Rng1.Count + Rng2.Count, 1 To 2)
'Amalgamate both ranges in array
shts = Array(Rng1, Rng2)
'First Loop "n" to loop through total number of cells in both ranges with Search term
For n = 1 To Rng1.Count + Rng2.Count
nn = n: c = 0
'Second loop to loop through actual ranges looking for search term.
For S = 0 To 1
For Each Dn In shts(S)
' Change count when second range appears
If n > Rng1.Count Then nn = n - Rng1.Count
'Change ranges when n > first range count
Set R = IIf(n > Rng1.Count, Rng2, Rng1)
'Count number of matches found
If Dn & "," & Dn.Offset(, 1) = R(nn) & "," & R(nn).Offset(, 1) Then c = c + 1
Next Dn
Next S
'if only one matche then place in array
If c = 1 Then
p = p + 1
Ray(p, 1) = R(nn)
Ray(p, 2) = R(nn).Offset(, 1)
End If
Next n
Range("D2").Resize(p, 2) = Ray
End Sub
Regards Mick
Bookmarks