Macro To Move All Duplicates To Another Sheet

[SGMacro]

I have found the macro below from this forum but it leaves 1 of the duplicate rows within the searched sheet, so if I have 4 duplicates 1 remains and 3 move to the other sheet. Original url here

I am trying to move all duplicates within a column into a separate worksheet within the same workbook. Being new to VB I am struggling so any help welcomed.

Sub CutDuplicates()
Dim Rng As Range, i As Long
    Application.ScreenUpdating = False
    Set Rng = Range("N2:N" & Range("N" & Rows.Count).End(xlUp).Row)
    For i = Rng.Rows.Count To 1 Step -1
        If Application.WorksheetFunction.CountIf(Rng, Cells(i, "N")) > 1 Then
          LR = Sheets("Duplicates").Cells(Rows.Count, "N").End(xlUp).Row + 1
          Rows(i).EntireRow.Cut Destination:=Sheets("Duplicates").Range("A" & LR)
          Rows(i).EntireRow.Delete
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[L. Howard]

This does that for my test sheet, but will take some adjustments to fit your sheet.

Also, may be a bit slow with the two loops.

Essentially, what it does, finds the duplicate entries in column A and offsets to column R with an "xx". Where column R is a column PAST the last used column of your sheet data.

Then defines column R as a range and for each "xx" resizes column A to column Q to 'Cut" to Sheet2, column A. Then clears column R.

So, if you are looking at column N, then myDataRng would be changed to N, and myCutRng would be changed to a 'far right of data' column and the OFFSET & RESIZE adjusted to cut row data to other sheet.

A bit clunky, I agree.

Howard

Option Explicit

Sub CUT_Dupes_New_Sheet()
    
    On Error GoTo ErrHandler
    
    Dim myDataRng As Range, myCutRng As Range
    Dim c As Range, cc As Range
    Dim lCol As Long
     
    Set myDataRng = Range("A2:A" & Cells(Rows.Count, "I").End(xlUp).Row)
 
    Application.ScreenUpdating = False
     
    For Each c In myDataRng
    
        If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & c.Address & ")") > 1 Then
            lCol = Cells(c.Row, Columns.Count).End(xlToLeft).Column
            c.Offset(, 17) = "xx"
        End If
        
    Next c
     
     Set myCutRng = Range("R2:R" & Cells(Rows.Count, "I").End(xlUp).Row)
       
    For Each cc In myCutRng
        If cc = "xx" Then
            cc.Offset(, -17).Resize(1, 17).Cut Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp)(2)
        End If
    Next cc
     
    Set myDataRng = Nothing
    Range("R:R").ClearContents
    
ErrHandler:
  
    Application.ScreenUpdating = True
End Sub

 

[SGMacro]

Thanks Howard thats worked a treat