http://www.sharewareplaza.com/Excel-List-Compare-download_16416.html
Sub CompareLists()
Dim iRow1 As Integer
Dim iRow2 As Integer
Dim iRow3 As Integer
Dim iTest1 As Long
Dim iTest2 As Long
iRow1 = 2
iRow2 = 2
iRow3 = 2
Do
If Sheet1.Cells(iRow1, 1) <> Sheet1.Cells(iRow2, 6) Or _
Sheet1.Cells(iRow1, 2) <> Sheet1.Cells(iRow2, 7) Then
Sheet2.Cells(iRow3, 5) = "No Match"
'If one list is longer than the other, will compare a number &
'a blank cell. The following is a work-around for a blank
cell.
If Sheet1.Cells(iRow1, 1) = "" Then
iTest1 = 100000000
Else
iTest1 = Sheet1.Cells(iRow1, 1)
End If
If Sheet1.Cells(iRow2, 6) = "" Then
iTest2 = 100000000
Else
iTest2 = Sheet1.Cells(iRow2, 6)
End If
If iTest1 < iTest2 Then
Sheet1.Range("A" & iRow1 & ":D" & iRow1).Copy
Sheet2.Range("A" & iRow3)
iRow1 = iRow1 + 1
Else
Sheet1.Range("F" & iRow2 & ":I" & iRow2).Copy
Sheet2.Range("F" & iRow3)
iRow2 = iRow2 + 1
End If
Else
Sheet1.Range("A" & iRow1 & ":D" & iRow1).Copy Sheet2.Range("A"
& iRow3)
Sheet1.Range("F" & iRow2 & ":I" & iRow2).Copy Sheet2.Range("F"
& iRow3)
iRow1 = iRow1 + 1
iRow2 = iRow2 + 1
End If
iRow3 = iRow3 + 1
Loop Until Sheet1.Range("A" & iRow1) = "" And Sheet1.Range("F" &
iRow2) = ""
End Sub
Hth,
Merjet