Find Duplicates on 2 different sheets & copy

Hi,
I need a macro which can find duplicates between sheet1 column A compared to sheet2 column A & copy the row into sheet 3. I need the macro to make a copy of the cells and copy it to sheet and delete the remaining entry? I appolgise if this is readily available its just Ive spend 4 hrs searching for it today with no success? Any help would be most appreciated.
Many Thanks
Johnny

Maybe:

Sub Burt_100()
Sheets("Sheet1").Columns("B:B").Insert xlToRight
With Sheets("Sheet1").Range("B2:B" & Sheets("Sheet1").UsedRange.Rows.Count)
    .Formula = "=VLOOKUP(B2,Sheet2!$A$2:$A$" & Sheets("Sheet2").UsedRange.Rows.Count & ",1,false)"
    .Value = .Value
    .Replace "#N/A", ""
End With
For Each rcell In Sheets("Sheet1").Range("B2:B" & Sheets("Sheet1").UsedRange.Rows.Count)
    If rcell.Value <> "" Then
        rcell.EntireRow.Copy Sheets("Sheet3").Range("A" & Rows.Count).End(3)(2)
        rcell.EntireRow.Delete xlUp
    End If
Next rcell
Sheets("Sheet1").Columns("B:B").Delete xlToLeft
    
End Sub

John,
I have tried out the sent code but it leaves the duplicates in sheet1 & sheet2 and copies the non duplicated data to sheet 3. I need it the opposite way around so that it leaves the non duplicated data in sheet1 & sheet2 and copies 1 copy of the duplicated data to sheet 3. Sorry to be a pain.
Thanks
Johnny

No pain at all. Try.

Sub Burt_100()
Sheets("Sheet1").Columns("B:B").Insert xlToRight
With Sheets("Sheet1").Range("B2:B" & Sheets("Sheet1").UsedRange.Rows.Count)
    .Formula = "=VLOOKUP(B2,Sheet2!$A$2:$A$" & Sheets("Sheet2").UsedRange.Rows.Count & ",1,false)"
    .Value = .Value
    .Replace "#N/A", ""
End With
For Each rcell In Sheets("Sheet1").Range("B2:B" & Sheets("Sheet1").UsedRange.Rows.Count)
    If rcell.Value = "" Then
        rcell.EntireRow.Copy Sheets("Sheet3").Range("A" & Rows.Count).End(3)(2)
        rcell.EntireRow.Delete xlUp
    End If
Next rcell
Sheets("Sheet1").Columns("B:B").Delete xlToLeft
    
End Sub

John,
I have attached a copy of the worksheet with the macro added but it doesnt seam to be working? Can you take a look at it and show me whats wrong?
Thanks
Johnny

Maybe:

Sub Burt_100()
Dim i As Long
Dim lr As Long

Sheets("Sheet1").Columns("B:B").Insert xlToRight
Sheets("Sheet1").Rows("1:1").Insert xlDown
Sheets("Sheet2").Rows("1:1").Insert xlDown
With Sheets("Sheet1").Range("B2:B" & Sheets("Sheet1").UsedRange.Rows.Count + 1)
    .Formula = "=VLOOKUP(A2,Sheet2!$A$2:$A$" & Sheets("Sheet2").UsedRange.Rows.Count + 1 & ",1,false)"
    .Value = .Value
    .Replace "#N/A", ""
End With
Sheets("Sheet1").Activate
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 2 Step -1
    If Range("B" & i).Value = Range("A" & i).Value Then
        Range("B" & i).EntireRow.Copy Sheets("Sheet3").Range("A" & Rows.Count).End(3)(2)
        Range("B" & i).EntireRow.Delete xlUp
    End If
Next i
Sheets("Sheet1").Rows("1:1").Delete xlUp
Sheets("Sheet2").Rows("1:1").Delete xlUp
Sheets("Sheet3").Rows("1:1").Delete xlUp
Sheets("Sheet1").Columns("B:B").Delete xlToLeft
Sheets("Sheet3").Columns("B:B").Delete xlToLeft
End Sub