Help remove duplicate rows

wilkisa

Well-known Member
Joined
Apr 7, 2002
Messages
657
Office Version
  1. 365
  2. 2016
  3. 2013
Platform
  1. Windows
We receive a large sheet from an outside source. It has 157 columns (A - FA), and 4041 rows.

The vendor name is in column C and the vendor address is in column D. I need a macro that will find duplicates and delete the entire row.

Example:

Col. C...Wonder Widgets...Col. D...123 Main
Col. C...Wonder Widgets...Col. D...456 Elm
Col. C...Wonder Widgets...Col. D...123 Main

I want to delete only the second occurance of Wonder Widgets at 123 Main. The other two Wonder Widgets should remain in the sheet.

Thanks in advance for any help,
Shirlene
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
G'day,

The Advanced Filter feature has a way to copy "unique records only" - this is a good method if you don't need a macro.

Hope that helps,
Adam
 
Upvote 0
I have tried the AutoFilter unique records feature but it won't work for these sheets. The problem is that the vendor who sends us the sheet has numbered each record with duplicate records having different numbers.

Any other suggestions?
 
Upvote 0
Are you opposed to using a VBA macros?
If not, what is the first row your data begins on?

Tom
This message was edited by TsTom on 2002-04-23 04:41
 
Upvote 0
Hi again.
If you need help with this please repost.
Assumes data starts on row 2...

Sub NoDups()
Dim RowCntr As Long, FromRowCntr As Long, LastRow As Long
Dim CompareStr
Dim FirstString As String, SecondString As String
On Error Resume Next
Range("A2:FZ20000").Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
LastRow = Range("C1:C" & Range("C65536").End(xlUp).Row).Rows.Count
For RowCntr = 2 To LastRow
For FromRowCntr = RowCntr + 1 To LastRow
FirstString = Range("C" & RowCntr) & Range("D" & RowCntr)
SecondString = Range("C" & FromRowCntr) & Range("D" & FromRowCntr)
CompareStr = StrComp(FirstString, SecondString, 1)
If CompareStr = 0 Then
Rows(FromRowCntr & ":" & FromRowCntr).Delete Shift:=xlUp
FromRowCntr = FromRowCntr - 1
End If
Next
Next
End Sub

Thanks,
Tom
This message was edited by TsTom on 2002-04-23 05:09
 
Upvote 0
The macro works great on sheets that are a few hundred rows. However, it dies while working in sheets of a few thousand rows. I ran it for 20 minutes on my sheet with 4041 rows and finally found that Excel stopped responding. Any ideas?
 
Upvote 0
Hi again,

I guess you could always go with a semi-manual method (a few steps but not too horrible):

1: insert a new column somewhere and on the 2nd row use the formula =C2&D2 (copy down).

The idea is to catch the criteria for a unique record - you may wish to add more cells to the concatenated to ensure a good criteria. For the example's sake I'll assume you type this formula in C2.

2. Insert a 2nd new column with the formula: =countif($C$2:C2,C2) (copy down again).

3. Copy and paste these columns as values

4. Sort by this numbered column, then manually delete any entries >1

5. (optional) resort by their initial order.

Hope that helps,
Adam
 
Upvote 0
Hi
Will need a sample sheet...
Unless someone can find out why my code is doing what you said.
I'm assuming that the deletion of the rows might be sending it into an endless loop.
Maybe try this as an alternative...

Sub NoDups()
Dim RowCntr As Long, FromRowCntr As Long, LastRow As Long
Dim CompareStr
Dim FirstString As String, SecondString As String
On Error Resume Next
Range("A2:FZ20000").Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
LastRow = Range("C1:C" & Range("C65536").End(xlUp).Row).Rows.Count
For RowCntr = 2 To LastRow
For FromRowCntr = RowCntr + 1 To LastRow
FirstString = Range("C" & RowCntr) & Range("D" & RowCntr)
SecondString = Range("C" & FromRowCntr) & Range("D" & FromRowCntr)
CompareStr = StrComp(FirstString, SecondString, 1)
If CompareStr = 0 Then
Rows(FromRowCntr & ":" & FromRowCntr).ClearContents
FromRowCntr = FromRowCntr - 1
End If
Next
Next
For RowCntr = LastRow To 2
If Range("C" & RowCntr) = "" Then _
Rows(RowCntr & ":" & RowCntr).Delete Shift:=xlUp
Next
End Sub

If that does not work and no one else provides a solution, then I will need a sample worksheet to test it out.
Tom
 
Upvote 0
Hi
I failed to adjust LastRow when a row was deleted.
Hence, the forever loop...
As an added precaution, I added this line of code:
If Len(Trim(FirstString)) = 0 Then Exit Sub
It is commented out. If you are still having problems then
make this line active in the code.
Sub NoDups()
Dim RowCntr As Long, FromRowCntr As Long, LastRow As Long
Dim CompareStr
Dim FirstString As String, SecondString As String
On Error Resume Next
Range("A2:FZ20000").Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
LastRow = Range("C1:C" & Range("C65536").End(xlUp).Row).Rows.Count
For RowCntr = 2 To LastRow
FirstString = Range("C" & RowCntr) & Range("D" & RowCntr)
'If Len(Trim(FirstString)) = 0 Then Exit Sub
For FromRowCntr = RowCntr + 1 To LastRow
SecondString = Range("C" & FromRowCntr) & Range("D" & FromRowCntr)
CompareStr = StrComp(FirstString, SecondString, 1)
If CompareStr = 0 Then
Rows(FromRowCntr & ":" & FromRowCntr).Delete Shift:=xlUp
FromRowCntr = FromRowCntr - 1
LastRow = LastRow - 1
End If
Next
Next
End Sub
Thanks,
Tom
 
Upvote 0
A macro can be created with the macro recorder by recording the following steps (note : it has been assumed that only column D needs to be checked for duplicates on the basis that a particular address will not have more than one customer name - if this is not the case, post again) :-

- Insert a column before column D
- In the inserted column, select from D1 down to the last row with data in column E
- Type in the formula =IF(COUNTIF($E$1:E1,E1)>1,1,"") and press Ctrl+Enter
- Go to Edit>GoTo>Special>Formula>Numbers and click OK
- Go to Edit>Delete>EntireRow
- Delete Column D


Here's a cleaned-up version of the recorded macro :-

Sub Delete_Duplicates()
Application.ScreenUpdating=False
Columns(4).Insert
With Range([E1], [E65536].End(xlUp)).Offset(0, -1)
.FormulaR1C1 = "=IF(COUNTIF(R1C5:RC[1],RC[1])>1,1,"""")"
On Error Resume Next
.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
On Error GoTo 0
.EntireColumn.Delete
End With
End Sub
This message was edited by Brabantio on 2002-04-23 19:30
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,243
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top