Help remove duplicate rows

[wilkisa]

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

[Asala42]

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

[wilkisa]

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?

[Tom Schreiner]

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 ]

[Tom Schreiner]

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 ]

[wilkisa]

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?

[Asala42]

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

[Tom Schreiner]

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

[Tom Schreiner]

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

[Brabantio]

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 ]