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.

 

[smsk]

Hello, I am looking for a macro that can identify duplicates and place them in another sheet based on the values of three columns. Does anyone has such code? thanks.

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!!

 

[mirabeau]

Hello, I am looking for a macro that can identify duplicates and place them in another sheet based on the values of three columns. Does anyone has such code? thanks.

It's not at all clear what you mean.

Could you post some sample data and specify what you want done with them?

 

[smsk]

For example, I have first name, last name, company, phone, email as the columns. I want to identify the duplicates where Fisrt name, Last Name and Company are same and then move the duplicates to another sheet. thanks.

It's not at all clear what you mean.

Could you post some sample data and specify what you want done with them?

 

[maximbebi]

ac

 

[maximbebi]

End

 

[rola baasiri]

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

Helloo
I tried the code above with my nearly 112,000 rows but somehow it didnt copy all the duplicated in my column,
What could be the problem ?

thanks for your help

 

[Yasmin_C]

Hi,

I know this is a old post, but I would like to ask if its possible to consider more then 1 column of value. In the below, it checks for Column DH. Would it be possible to check for example, DH and DI? I have a table of data but need to remove the duplicates in consideration of 2 columns(AND). Please advise if anyone is reading this. Thanks.

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

 

[rafcik]

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

@mirabeau mate, I know this is an old post, it but it fixed precisely the problem I had. Thank you very very much! (I spent two days with this haha)
If you read this, have a nice day!

Rafcik