jd

Try this

Sub comparelists2()

Dim Rng1 As Range, Rng2 As Range
Dim RwNum As Long
Const ColNum As Long = 10
Dim cell1 As Range, cell2 As Range
Dim UsedRow As Long
Dim SecCol As Boolean

Set Rng1 = Sheet1.Range("a1:c7")
Set Rng2 = Sheet1.Range("e1:g6")
RwNum = 2

For Each cell1 In Rng1.Columns(1).Cells
Sheet1.Cells(RwNum, ColNum).Resize(, Rng1.Columns.Count) _
.Value = Intersect(Rng1, cell1.EntireRow).Value

For Each cell2 In Rng2.Columns(1).Cells
If cell1.Value = cell2.Value Then
Sheet1.Cells(RwNum, ColNum + Rng1.Columns.Count + 1) _
.Resize(, Rng2.Columns.Count).Value = _
Intersect(Rng2, cell2.EntireRow).Value
RwNum = RwNum + 1
SecCol = True
End If
Next cell2

RwNum = RwNum + Abs(CLng(Not SecCol))
SecCol = False
Next cell1

For Each cell2 In Rng2.Columns(1).Cells
If Rng1.Find(cell2.Value, , , xlWhole) Is Nothing Then
Sheet1.Cells(RwNum, ColNum + Rng1.Columns.Count + 1) _
.Resize(, Rng2.Columns.Count).Value = _
Intersect(Rng2, cell2.EntireRow).Value
RwNum = RwNum + 1
End If
Next cell2

End Sub

--
Dick Kusleika
MVP - Excel
www.dicks-clicks.com
Post all replies to the newsgroup.

"jdcollins21" wrote in message
...
I used this macro two solve a similar problem but still have an issue.
In my 2nd(smaller list), I have unique entries. Is there a way to move
these to the bottom of the newer sorted list?



------------------------------------------------
~~ Message posted from http://www.ExcelTip.com/
~~ View and post usenet messages directly from http://www.ExcelForum.com/