MACRO Find Duplicates move to new worksheet

[phmic]

Hi,

I am looking for some code help with finding duplicates and moving them to a new spreadsheet.

I am looking for duplicates between Sheet 1 and Sheet 2 Col (A) "policy num". I would like the duplicates to be moved to a new sheet (Sheet 3).
I would like the new sheet with the duplicates to then pull the information for Columns B a ( Effective date) from Sheet 1 and Columns C and D (Add'l policy exec 1 - Add'l Policy Exec2) from Sheet 2. I would like Sheet 1 and Sheet 2 to stay intact (so no deleting the duplicates or non-duplicates).

Worksheet one (sorry about the spaces)

Policy Number Effective Date Add'l Policy Exec 1 Add'l Policy Exec 2
PP123 1/1/2010
PP124 1/2/2010
PP125 1/3/2010
zz154 2/14/2010
zz155 2/15/2010
zz156 2/16/2010
hh11 2/17/2010
hh12 2/18/2010


Worksheet 2 (sorry about the spacing) All the (Bank) should be under add'l policy exec 1 and the names are under policy exec 2

Policy Number Effective Date Add'l Policy Exec 1 Add'l Policy Exec 2
PP123 1/1/2010 Bank
PP124 1/2/2010 Kim
PP125 1/3/2010 Bank
PP126 1/4/2010
PP127 1/5/2010 Kim
PP128 1/6/2010
zz154 2/14/2010 Bank
zz155 2/15/2010 Troy
zz156 2/16/2010
zz157 2/17/2010 Bank
zz158 2/18/2010 Troy
zz159 2/19/2010

[nimrod]

Public Sub CopyIfDupes()

   'CONFIG SHEET INFO HERE
   Set SrcSh1 = Sheets("Sheet1")
   Set SrcSh2 = Sheets("Sheet2")
   Set TargSh = Sheets("Sheet3")
   Const PolicyNumCol As Integer = 1
   
   For Each PolicyNum In SrcSh1.Cells(1, PolicyNumCol).EntireColumn.SpecialCells(xlCellTypeConstants, 3)
     With SrcSh2.Cells(1, PolicyNumCol).EntireColumn
       Set c = .Find(PolicyNum.Value, LookIn:=xlValues, lookat:=xlWhole)
       If Not c Is Nothing Then
          With TargSh
             NextTargRow = .Cells(.Cells(1, PolicyNumCol).EntireColumn.Cells.Count, PolicyNumCol).End(xlUp).Row + 1
             
             .Cells(NextTargRow, 1).Value = PolicyNum.Value
             .Cells(NextTargRow, 2).Value = SrcSh1.Cells(PolicyNum.Row, 2).Value
             .Cells(NextTargRow, 3).Value = SrcSh2.Cells(c.Row, 3).Value
             .Cells(NextTargRow, 4).Value = SrcSh2.Cells(c.Row, 4).Value
          End With
       End If
     End With
   Next PolicyNum
End Sub

[phmic]

Thanks! Works perfectly!