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