Compare Lists and Copy Duplicates

[helpexcel]

Hi - I found a few threads on this topic, but I'm struggling. I have 2 lists, Sheets1 Column A and Sheets2 Column B. What i'd like to happen is if the item on Sheets1 appears on Sheets2, then copy the whole row (columns A:E) to Sheets3 A6. I would be running this code mutliple times so if i could get it to copy to next available row would be great. Playing with a bunch of different codes, at some point this stuff will make sense to me.

Thanks!!

 

[mumps]

Try:

Sub CompareLists()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, LastRow As Long
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In Sheets("Sheet2").Range("B1", Sheets("Sheet2").Range("B" & Sheets("Sheet2").Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next Rng
    For Each Rng In Sheets("Sheet1").Range("A1", Sheets("Sheet1").Range("A" & Sheets("Sheet1").Rows.Count).End(xlUp))
        If RngList.Exists(Rng.Value) Then
            LastRow = Sheets("Sheet3").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If LastRow < 6 Then LastRow = 5
            Rng.EntireRow.Copy Sheets("Sheet3").Range("A" & LastRow + 1)
        End If
    Next Rng
    RngList.RemoveAll
    Application.ScreenUpdating = True
End Sub

 

[wideboydixon]

Give this a try. You didn't specify whether you wanted to remove the row from Sheet1 so I didn't do that:

Public Sub HelpExcel001()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet

Dim lastRow As Long
Dim thisRow As Long
Dim nextRow As Long
Dim foundRow As Variant

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set ws3 = Sheets("sheet3")

lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
nextRow = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row + 1

For thisRow = 1 To lastRow ' Change 1 to 2 if there's a header
    foundRow = Application.Match(ws1.Cells(thisRow, "A").Value, ws2.Range("B:B"), 0)
    If Not IsError(foundRow) Then
        ws1.Range(ws1.Cells(thisRow, "A"), ws1.Cells(thisRow, "E")).Copy ws3.Cells(nextRow, "A")
        nextRow = nextRow + 1
    End If
Next thisRow

End Sub

WBD

 

[helpexcel]

WBD - Works great thanks!!! What would I need to add to remove the items from sheets1 after copying?

Mumps, thank you also!!

 

[wideboydixon]

Slightly different to remove once copied:

Public Sub HelpExcel001()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet

Dim lastRow As Long
Dim thisRow As Long
Dim nextRow As Long
Dim foundRow As Variant

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set ws3 = Sheets("sheet3")

lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
nextRow = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row + 1

Application.ScreenUpdating = False

thisRow = 1 ' Change 1 to 2 if there's a header
Do While thisRow <= lastRow
    foundRow = Application.Match(ws1.Cells(thisRow, "A").Value, ws2.Range("B:B"), 0)
    If IsError(foundRow) Then
        thisRow = thisRow + 1
    Else
        ws1.Range(ws1.Cells(thisRow, "A"), ws1.Cells(thisRow, "E")).Copy ws3.Cells(nextRow, "A")
        nextRow = nextRow + 1
        ws1.Cells(thisRow, "A").EntireRow.Delete xlShiftUp
        lastRow = lastRow - 1
    End If
Loop

Application.ScreenUpdating = True

End Sub

WBD

 

[helpexcel]

That's great!!! Can I Bug you for another update. Is there a way to reorder the items left on Sheet1 so that there are no blank lines in between items?

 

[wideboydixon]

It already deletes the entire row when it copies the row to Sheet3. Are there other blank rows in the sheet before this runs?

WBD

 

[helpexcel]

There could be items on Sheet1 that aren't on Sheet2. This would leave blank rows where the items that matched were copied to sheet3.

 

[wideboydixon]

Before:

Book1
	A	B	C	D	E
1	a	a	a	a	a
2	b	b	b	b	b
3	c	c	c	c	c
4	d	d	d	d	d
5	e	e	e	e	e
6	f	f	f	f	f
7	g	g	g	g	g
8	h	h	h	h	h
9	i	i	i	i	i
10	j	j	j	j	j
Sheet1

Book1
	B
1	a
2	c
3	e
4	g
5	i
Sheet2

After:

Book1
	A	B	C	D	E
1	b	b	b	b	b
2	d	d	d	d	d
3	f	f	f	f	f
4	h	h	h	h	h
5	j	j	j	j	j
Sheet1

Book1
	A	B	C	D	E
2	a	a	a	a	a
3	c	c	c	c	c
4	e	e	e	e	e
5	g	g	g	g	g
6	i	i	i	i	i
Sheet3

It removes the row when it's copied to Sheet3.

WBD

 

[helpexcel]

My fault!! Sorry!!! I changed the code to take out EntireRow.Delete xlShiftUp and replaced it with ClearContents because I have a validation list in Columns A and G and a formula in Column F.