Extract duplicates

**excelexcess** · 08-04-2007, 05:18 PM

I would like to extract a list of duplicate products based on location.

Any product duplicated with products in location ob* are placed in a new list.

Please refer to the posted simplified sheet for reference.

The spreadsheet in question has thousands of rows so i would like the duplicates list to be compiled in a new sheet.

Please forgive my poor use of terminology, and thanks in advance for any suggestions posted.

Thanks again

**Leith Ross** · 08-04-2007, 11:19 PM

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

**FrankBoston** · 08-04-2007, 11:24 PM

See the attached file for worksheet formulas and associated Macro code that will move rows from sheet to sheet (or workbook to workbook, for that matter).

The worksheet formulas identify the rows that you want to move. This integrates with the code that moves the rows.

This workbook uses a specialized Sub to call the more general code. I will leave it to your taste as to how you want to implement the actual move.

'---------------
Sub aaMoveRows()
MoveRowsDo Range("Sheet1!E2:E18"), Range("A:C"), Range("Sheet2!B3")
End Sub

'-------------
' Move rows from one sheet to another
' Usage:  MoveRows(ShOne!G2:G100, B1:F1, ShTwo!C5)
'  Look at cells G2:G100 in workheet ShOne
'  For each cell = numeric 1, move the cells B:F in that row
'     to the destination sheet ShTwo
'  Begin placement at C5 in ShTwo, copying formulas and values
'  to successive rows.
'
Sub MoveRowsDo(rDecide As Range, rFrom As Range, ByVal rTo As Range)
Dim cc As Range, src As Range
Dim off0 As Long, off1 As Long

off0 = rFrom.Column - rDecide.Column
off1 = off0 + rFrom.Columns.Count - 1

For Each cc In rDecide
 If IsNumeric(cc) Then
 If cc = 1 Then 'move this row
   Set src = Range(cc.Offset(0, off0), cc.Offset(0, off1))
   src.Copy Destination:=rTo  'Copy to destination sheet
   Set rTo = rTo.Offset(1, 0) 'Next line to copy to
 End If
 End If
Next cc
End Sub