Extract duplicates

Hello Excelexcess,

This macro will keep only the duplicate products that contain the string "ob" in them. The data must be sorted by product before the macro is run. You can change both the data table cells, and also the location of the new table (code is in blue). The macro is not designed to overwrite the original table. This is installed in the attached workbook.
Macro Code

'User: Excelexcess
'URL: http://www.excelforum.com/showthread.php?t=609757
'Written: August 4, 2007
'Author: Leith Ross

Sub CopyDuplicates()

  Dim Cnt As Long
  Dim CopyCol As Long
  Dim CopyRng As Range
  Dim I As Long
  Dim LastRow As Long
  Dim MainRng As Range
  Dim Res As Boolean
  Dim Rng As Range
  

    Set MainRng = Range("A1:C16")
    Set CopyRng = Range("A21")
    
    ' Copy the list
      CopyCol = CopyRng.Column
      MainRng.Copy Destination:=CopyRng
    
    ' Determine the start and last row
      With Worksheets(CopyRng.Parent.Name)
        FirstRow = CopyRng.Row
        LastRow = .Cells(.Rows.Count, CopyCol).End(xlUp).Row
      End With
      
    ' Remove unique product rows
      For I = LastRow To FirstRow + 1 Step -1
        Cnt = Cnt + 1
          If Cells(I, CopyCol + 2) <> Cells(I - 1, CopyCol + 2) Then
            If Cnt = 1 Then
               Range(Cells(I, CopyCol), Cells(I, CopyCol + 2)).Delete (xlShiftUp)
            End If
            Cnt = 0
          End If
      Next I
    
    ' Recalculate the row limits
      With Worksheets(CopyRng.Parent.Name)
        FirstRow = CopyRng.Row
        LastRow = .Cells(.Rows.Count, CopyCol).End(xlUp).Row
      End With
      
    ' Keep repeat locations if they contain "ob" in them
      Cnt = 0
        For I = LastRow To FirstRow + 1 Step -1
          Cnt = Cnt + 1
            If Cnt = 1 Then Set Rng = Range(Cells(I, CopyCol), Cells(I, CopyCol + 2))
          Set Rng = Union(Rng, Range(Cells(I, CopyCol), Cells(I, CopyCol + 2)))
          If InStr(1, Cells(I, CopyCol), "ob") > 0 Then Res = True
          If Cells(I, CopyCol + 2) <> Cells(I - 1, CopyCol + 2) Then
             If Not Res Then Rng.Delete (xlShiftUp)
             Cnt = 0
             Res = False
          End If
      Next I
              
End Sub

Sincerely,
Leith Ross