![EEK!](https://www.excelforum.com/images/smilies/eek.gif)
This will actually delete rows that are duplicates leaving you only with the unique names.
I just copied and pasted it from my utility. You can get the whole thing from -
http://www.geocities.com/excelmarksw...Duplicates.xls
Public Sub ClearDuplicates()
Dim strWholeRow, strCompareRow As String
Dim intRows, intCols, intNum, intNext, i As Integer
Dim cell
Application.ScreenUpdating = False
intNum = 0
intRows = 0
intCols = 0
intNext = 0
i = 0
strWholeRow = ""
Range("A2").Select
Set a = Selection
Range(a, a.SpecialCells(xlLastCell)).Select
intRows = Selection.Rows.Count
intCols = Selection.Columns.Count
a.Select
'GoTo DelBlankRows
Do
For intNum = 0 To intCols
strWholeRow = strWholeRow & a.Offset(0, intNum)
Next
'strwholerow=all cells in the row
For intNext = 1 To intRows + 1
Set x = a.Offset(intNext, 0)
'next row to compare
strCompareRow = ""
'build the next string to compare against the strwholerow
For intNum = 0 To intCols
strCompareRow = strCompareRow & x.Offset(0, intNum)
Next
'Clear contents not delete row so the row count is not affected.
'Delete blank rows at the end
If UCase(strWholeRow) = UCase(strCompareRow) Then
Range(x, x.Offset(0, intCols)).ClearContents
End If
'go to next row
Next
Set a = a.Offset(1, 0)
strWholeRow = ""
i = i + 1
Loop Until i > intRows
DelBlankRows:
'Delete blank Rows
i = 0
Range("A2").Select
Set a = Selection
Do
strWholeRow = ""
'Range("A1").Value = a.Row
a.Select
For intNum = 0 To intCols
strWholeRow = strWholeRow & a.Offset(0, intNum)
Next
intNum = a.Row
If Len(strWholeRow) = 0 Then
Rows(intNum).EntireRow.Delete 'shift:=xlUp
ActiveCell.Offset(0, 0).Select
Set a = Selection
intRows = intRows - 1
Else
Set a = a.Offset(1, 0)
End If
Loop Until a.Row >= intRows
Range("A2").Select
End Sub
Bookmarks