Macro to Move Duplicate Rows to a Separate Sheet

[data_fiddler]

I'm new to MrExcel.com and Macros/VBA in general. I've been watching tutorial videos on Macros like crazy in order to help me put together a Macro for something I'm working on.

My workbook contains a large amount of data (i.e. one of the worksheets contains 169 columns with 112,000 rows of data). Within all of this data, there is a unique value in column DH (account number in numerical format). Each account number should only exist one time within this sheet. However, there are some duplicate rows of data. My goal is to remove all of the duplicate rows and place them in a separate sheet titled 'Duplicates'.

The way I've been doing this so far has been taking me an extraordinary amount of time and I know there must be a quicker way of getting this done. What I did first was I sorted column DH in numerical order, from least to greatest. Next, I used Conditional Formatting to format the font of all duplicate values in column DH as a bold red color. After that was completed, I would Page Dn starting from row one looking for bold red values within column DH. Once I found some values that were formatted in that manner, I would highlight the duplicate rows of data (usually one row but sometimes two or three) and 'Cut' the row, then I would go to the 'Duplicates' sheet and paste the row there. Then I would go back to my previous sheet, delete the empty row I just cut, and repeat the process.

I tried to record a macro for this process and here's what it looks like:

Sub Remove_Duplicate_Service_Accounts()
'
' Remove_Duplicate_Service_Accounts Macro
'
' Keyboard Shortcut: Ctrl+Shift+D
'
Rows("14253:14253").Select
Range("Z14253").Activate
Selection.Cut
Sheets("Duplicates").Select
Range("A2").Select
ActiveSheet.Paste
Range("A3").Select
Sheets("Survey (Nov. 09-Dec. 10)").Select
ActiveWindow.LargeScroll Down:=1
Range("Z14284").Select
ActiveWindow.LargeScroll Down:=1
Rows("14328:14328").Select
Range("Z14328").Activate
Selection.Cut
Sheets("Duplicates").Select
ActiveSheet.Paste
Range("A4").Select
Sheets("Survey (Nov. 09-Dec. 10)").Select
End Sub


I know it's not right so I could really use some help! Any feedback would be greatly appreciated! I've also included a screenshot of my workbook for you to get a better idea of what I'm talking about.

 

[Datsmart]

This code will Cut Duplicate rows on the active worksheet based on Column DH.
It will paste the cut rows in the worksheet named "Duplicates".

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

This was tested on a 50 row test sheet, but it should also work on your larger row worksheet.

 

[data_fiddler]

This code will Cut Duplicate rows on the active worksheet based on Column DH.
It will paste the cut rows in the worksheet named "Duplicates".

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

This was tested on a 50 row test sheet, but it should also work on your larger row worksheet.

Thank you for the reply and info!

I tried using the code you provided me and I received the following run time error:

When I clicked on 'Debug', this is what it showed me:

 

[Datsmart]

OK, in my test sheet I used column A to check for my duplicates. Then changed all "A" references to "DH", I shouldn't have changed the target column though. Change the red line of code to this:

Rows(i).EntireRow.Cut Destination:=Sheets("Duplicates").Range("A" & lr)

You can not paste an entire row to any cell but to column A. As you noted, it will not fit.

 

[data_fiddler]

OK, in my test sheet I used column A to check for my duplicates. Then changed all "A" references to "DH", I shouldn't have changed the target column though. Change the red line of code to this:

Rows(i).EntireRow.Cut Destination:=Sheets("Duplicates").Range("A" & lr)

You can not paste an entire row to any cell but to column A. As you noted, it will not fit.

That worked perfectly! Thanks again! Unfortunately it didn't work too good on my sheet containing 112,000 rows. I started the macro at 10am that day and it was still working at 10am the next day! Maybe my computer just froze? Not too sure. But then I tried it on a sheet of 3,000 rows and it took 5 seconds.

 

[mirabeau]

Hi,

Try this one on some test data.

1. It assumes duplicates are considered for Column"DH" (xcol in about 5th line)

2. Assumes you already have a sheet called "Duplicates" to which to copy.

3. With 112,000 rows and 169 columns it should take only a minute or so to remove and copy the rows in which duplicates in Col DH occur.

Sub duplicstuff()
Dim t As Single
t = Timer
Dim d As Object, x&, xcol As String
Dim lc&, lr&, k(), e As Range
xcol = "DH"
lc = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Column
lr = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Row
ReDim k(1 To lr, 1 To 1)
Set d = CreateObject("scripting.dictionary")
For Each e In Cells(1, xcol).Resize(lr)
    If Not d.exists(e.Value) Then
        d(e.Value) = 1
        k(e.Row, 1) = 1
    End If
Next e
If d.Count = lr Then
    MsgBox "No duplicates"
    Exit Sub
End If
Cells(1, lc + 1).Resize(lr) = k
Range("A1", Cells(lr, lc + 1)).Sort Cells(1, lc + 1), 1
x = Cells(1, lc + 1).End(4).Row
Cells(x + 1, 1).Resize(lr - x, lc).Copy Sheets("Duplicates").Range("A1")
Cells(x + 1, 1).Resize(lr - x, lc).Clear
Cells(1, lc + 1).Resize(x).Clear
MsgBox "Code took " & Format(Timer - t, "0.00 secs")
MsgBox lr & " rows" & vbLf & lc & " columns" & vbLf & _
    lr - x & " duplicate rows"
End Sub

 

[dmwilson38550m]

Hi,

Is there any way the macro can be used to remove/copy to another tab duplicate cell values where the cell is not a numeric value but an alpha numeric value (eg BANK100, LEDGER 100) - ideally I want to identify and remove all equal entries from 2 different data sources (eg all BANK100 with all LEDGER100,all BANK555 with LEDGER555 etc.

Thanks,
David

 

[mirabeau]

I'm not sure that I entirely follow your meaning.

That macro should copy/remove any rows with duplicated values (all or each of numeric, string, alphanumeric or whatever) in Column DH.

Have you tried it and found that it doesn't do this?

I'd like any further details that you can provide.

 

[mmnunn]

Hi all-

i have read through the code in this thread for finding and moving duplicate rows to a new sheet but this leaves one row of data left. how would i write the code to find a cell, check to see if it has duplicates and if so, then move all of those rows to a new sheet?

ex. if column DH had "FRANK" in it 4 times, listed in sequence so say rows 5-8, i would like to move all 4 of those rows to another sheet not just 3 of them like the code above does.

thank you in advance for any guidance you can provide.

 

[stitcher]

OMG!!! You have no idea how much easier you have made my life. I was given a spreadsheet of over 700 people...many partial duplicates which would not import correctly in one file. Your macro below makes it possible to import them with just a few keystrokes. Thank you ever so much!!

Hi,

Try this one on some test data.

1. It assumes duplicates are considered for Column"DH" (xcol in about 5th line)

2. Assumes you already have a sheet called "Duplicates" to which to copy.

3. With 112,000 rows and 169 columns it should take only a minute or so to remove and copy the rows in which duplicates in Col DH occur.

Sub duplicstuff()
Dim t As Single
t = Timer
Dim d As Object, x&, xcol As String
Dim lc&, lr&, k(), e As Range
xcol = "DH"
lc = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Column
lr = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Row
ReDim k(1 To lr, 1 To 1)
Set d = CreateObject("scripting.dictionary")
For Each e In Cells(1, xcol).Resize(lr)
    If Not d.exists(e.Value) Then
        d(e.Value) = 1
        k(e.Row, 1) = 1
    End If
Next e
If d.Count = lr Then
    MsgBox "No duplicates"
    Exit Sub
End If
Cells(1, lc + 1).Resize(lr) = k
Range("A1", Cells(lr, lc + 1)).Sort Cells(1, lc + 1), 1
x = Cells(1, lc + 1).End(4).Row
Cells(x + 1, 1).Resize(lr - x, lc).Copy Sheets("Duplicates").Range("A1")
Cells(x + 1, 1).Resize(lr - x, lc).Clear
Cells(1, lc + 1).Resize(x).Clear
MsgBox "Code took " & Format(Timer - t, "0.00 secs")
MsgBox lr & " rows" & vbLf & lc & " columns" & vbLf & _
    lr - x & " duplicate rows"
End Sub