Removing duplicate entries

  • Thread starter Thread starter Billy
  • Start date Start date
B

Billy

This should be simple. I have a spreadsheet with one column and several
thousand rows. Each cell contains a phone number. I want to delete all but
one of each duplicate number so that I end up with all unique numbers. How
can this be done quickly?
 
Thanks for the quick response Oscar, but I am quite a novice. I have no
idea what a pivot table is. I just thought there might be a function or
macro I could run to do this.

Billy
 
Select all data > Menu > Data > Pivotable

Billy said:
Thanks for the quick response Oscar, but I am quite a novice. I have no
idea what a pivot table is. I just thought there might be a function or
macro I could run to do this.

Billy
Click to expand...
 
Goto:

Data: -> Filter -> Advance Filter

here select filter for unique values in place..

then:

ctlr + g this will open a goto dialogue box.. here select special and
then in options select visible cells ... copy the cells and paste it in
another worksheet.. this a simple and second fast method.
you can even record macro for this.
 
Billy

the following code based on an example in the JWalk website will
delete the rows containing duplicates leaving one original entry. It
assumes you have selected the range you wish to deduplicate

Sub Uniques_Delete_Row()
Dim AllCells, Cell, DelRange As Range
Dim i, j, k As Integer
Dim NoDupes As New Collection

'break key calls errorhandler
On Error GoTo ErrorHandler
Application.EnableCancelKey = xlErrorHandler
'check we are in worksheet
If TypeName(ActiveSheet) <> "Worksheet" Then
MsgBox "This macro only works on a worksheet"
Exit Sub
End If

'downsize selection to be within used range
Set AllCells = Intersect(ActiveSheet.UsedRange, Selection)

'The next statement ignores the error caused
'by attempting to add a duplicate key to the collection.
'The duplicate is not added - which is just what we want!
For Each Cell In AllCells
On Error GoTo ErrorDuplicate
If Cell.Value <> vbNullString Then
NoDupes.Add LCase(Cell.Value), CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must
be a string
End If
Next Cell

If DelRange Is Nothing Then
Exit Sub
Else
DelRange.EntireRow.Delete
End If

Exit Sub
ErrorDuplicate:
'collect the cells to be deleted
If DelRange Is Nothing Then
Set DelRange = Cell
Else
Set DelRange = Union(DelRange, Cell)
End If

Resume Next

ErrorHandler:
Beep
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
Response = MsgBox("Macro unexpectedly terminated because" &
Chr(13) & Error(Err), vbCritical, "Macro terminated")
Exit Sub

End Sub

hth

Mike B
 
This will preserve your original data and give you non-
duplicates.

Sub unique_values()
'Creates a sorted list of unique values starting at Target
'Rev A 27/5/2003

'PRELIMINARIES
Dim Examine As String, Target As String, ThisPrompt As
String, title As String
Dim UserRng_A As Range, UserRng_B As Range
Dim valu As Variant

'STEP 1 DETERMINE WHERE THE RAW DATA IS
ThisPrompt = "Where is the top of the VALUES to test ? eg
A3 or B5"
title = "UNIQUE VALUES (Rev A)"
On Error Resume Next ' in case a range does not get
selected
'The use of the "Set" statement assigns the output to the
selected ActiveCell
Set UserRng_A = Application.InputBox(prompt:=ThisPrompt,
title:=title, _
Default:=ActiveCell.Address, Type:=8) '"Type 8" means a
Range result.
If UserRng_A Is Nothing Then 'input was box cancelled
MsgBox "Cancelled"
Exit Sub ' Rev A
End If

'STEP 2 DETERMINE WHERE TO PUT THE LIST
ThisPrompt = "Where is the Data to be put ?" _
& Chr(13) & Chr(13) & "You will need blank cells under the
it."
Set UserRng_B = Application.InputBox(prompt:=ThisPrompt,
title:="Select a cell", _
Default:=ActiveCell.Address, Type:=8)
If UserRng_B Is Nothing Then
MsgBox "Cancelled"
Exit Sub ' Rev A
End If
Target = UserRng_B.Address() 'the address of the selected
cell

'STEP 3 GATHER BASIC DATA
Application.ScreenUpdating = False
UserRng_A(0, 1).Select 'select the cell above
Examine = Selection.Address() 'the address of the cell
above
valu = Selection.Formula 'store the contents of the cell
one row above the first data
UserRng_A(0, 1).Formula = "temporary string" 'THE ADVANCED
FILTER DEMANDS A STRING IN THIS CELL


'STEP 4 CREATE THE UNIQUE ENTRIES
Range(Target).Clear 'needed to stop filtering falling over
Range(Examine).Activate 'filter then insert unique values
starting at Target
Range(Examine, ActiveCell.End(xlDown)).AdvancedFilter
Action:=xlFilterCopy, _
CopyToRange:=Range(Target), Unique:=True
'now sort the values
Range(Target).Select 'musn't remove this line
Range(Target, ActiveCell.End(xlDown)).Select
Selection.Sort Key1:=Range(Target), Order1:=xlAscending,
Header:=xlYes, _
OrderCustom:=1

'STEP 5 TIDY UP
UserRng_B.Formula = ""
Range(Examine).Formula = valu 'restore the original entry
to this cell
Application.ScreenUpdating = True

End Sub
 
Back
Top