Check sheet1 Copy duplicate items rows on sheet2 to sheet3

I have two sheets , sheet1 and sheet2 , in sheet1 i have some data on column A and in sheet 2 also i have some data ,

Now i need a VBA code that check the column A on sheet1 and if find the duplicate on column A on sheet2 copy all the rows of duplicated item on sheet2 to sheet 3 .

The important thing copy all the duplicated rows in sheet2 to sheet3 .

Sample :

http://i58.tinypic.com/10ojtdc.png

Thank you

Code:

---

Sub a()
Set sh1 = Sheets(1)
Set rng2 = Sheets(2).UsedRange
Set sh3 = Sheets(3)
drow = 1
LR = sh1.Cells(Rows.Count, "A").End(xlUp).Row
For r = 1 To LR
  nam = sh1.Cells(r, 1)
  If Application.WorksheetFunction.CountIf(rng2.Resize(, 1), nam) > 1 Then
    For rr = 1 To rng2.Rows.Count
      If rng2(rr, 1) = nam Then
        sh3.Cells(drow, 1) = rng2(rr, 1)
        sh3.Cells(drow, 2) = rng2(rr, 2)
        drow = drow + 1
      End If
    Next
  End If
Next
 
End Sub

---

Thank you very much but it will copy only column A and B i need copy the row .

Thank you again

This can be done with 1, perhaps 2 lines:

Code:

---

Sub Macro2()
Sheets("Sheet3").Cells.Clear
Sheets("Sheet2").Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Sheet1").Range("A1:A2"), CopyToRange:=Sheets("Sheet3").Range("A1"), Unique:=False
End Sub

---

but...
Sheet2 needs to have unique headers in row 1 in as many columns as you want to copy across.
Sheet1 needs the single header in A1 exactly the same as column A header in sheet2, as well as the value sought in A2
The code line starting:

Code:

---

Sheets("Sheet2").Columns("A:B").AdvancedFilter…

---

needs adjusting to cover the columns you want to copy over, so if 5 columns, you need to change it to:
Sheets("Sheet2").Columns("A:E").AdvancedFilter…
and again, all columns must have a header.

Thank you very much p45cal