Sub OnlyDuplicates()
Dim iRng As Range
Dim arr(), arrDup()
Dim I&, J&, N&, iTmp
Dim dic As Object
Application.ScreenUpdating = False
On Error Resume Next
With Worksheets("TDSheet")
  Set iRng = .Range("A2:P" & .UsedRange.Rows.Count)
  arr = iRng.Value
End With
Set dic = CreateObject("Scripting.Dictionary")
For I = LBound(arr, 1) To UBound(arr, 1)
  If arr(I, 12) <> "" Then
    iTmp = dic(arr(I, 12))
  End If
Next
ReDim arrDup(LBound(arr, 1) To UBound(arr, 1), LBound(arr, 2) To UBound(arr, 2))
For I = LBound(arr, 1) To UBound(arr, 1)
  If dic.Exists(arr(I, 2)) Then
    N = N + 1
    For J = LBound(arrDup, 2) To UBound(arrDup, 2)
      arrDup(N, J) = arr(I, J)
    Next
  End If
Next
iRng.Clear
Worksheets("TDSheet").Range("A2").Resize(N, UBound(arrDup, 2)) = arrDup
Application.ScreenUpdating = True
End Sub