Gilles or NumbrsDude:
Can you tell me if this is what I want and how to I insert this code.
I have the goods you want in a file, I do believe.
This code will go through all of the values in ONE column, and delete ALL
of the duplicates. In other words, if 6 records start with 12345, then all 6
records are deleted, NOT just the 5 duplicates.
Here's the code:
Sub DeleteDuplicateRows()
Dim rng As Range
Dim cl As Range
Dim rngOriginal As Range
Dim rngDups As Range
Dim strCol As String
Dim strRangeErr As String
strRangeErr = "Error with your range, please try again"
On Error Resume Next
Set rngOriginal = Selection
Set rng = Application.InputBox("Please select the range that you would
like to " & _
"delete rows from - please make sure that you only select ONE
column " & _
"in your range.", "Select Range", , , , , , 8)
If Err <> 0 Then
MsgBox strRangeErr, vbCritical, "Exiting..."
GoTo ExitHere
ElseIf rng Is Nothing Then
MsgBox strRangeErr, vbCritical, "Exiting..."
GoTo ExitHere
ElseIf rng.Columns.Count > 1 Then
MsgBox "You selected a range that has more than one column -
please " & _
"re-run this program and select only one column.", vbCritical,
"Exiting..."
GoTo ExitHere
ElseIf rng.Rows.Count <= 1 Then
MsgBox "There are no duplicates in one cell! Please try again and
select more " & _
"than one cell.", vbCritical, "Exiting..."
GoTo ExitHere
End If
On Error GoTo HandleErr
Application.ScreenUpdating = False
rng.Range("A1").Offset(0, 1).Select
Selection.EntireColumn.Insert
ActiveCell.Formula = "=COUNTIF(" & rng.Address & "," & _
Application.ConvertFormula(rng.Range("A1").Address, xlA1, xlA1,
xlRelative) & _
")"
Selection.AutoFill _
Destination:=Range(rng.Range("A1").Offset(0, 1), _
rng(rng.Rows.Count, rng.Columns.Count).Offset(0, 1)), _
Type:=xlFillDefault
For Each cl In _
Range(rng.Range("A1").Offset(0, 1), rng(rng.Rows.Count,
rng.Columns.Count).Offset(0, 1))
If cl.Value > 1 Then
If rngDups Is Nothing Then
Set rngDups = Range(cl.Address)
Else
Set rngDups = Application.Union(rngDups, Range(cl.Address))
End If
End If
Next cl
rngDups.EntireRow.Delete
rng.Offset(0, 1).EntireColumn.Delete
If Not (rngOriginal Is Nothing) Then
rngOriginal.Select
Else
Range("A1").Select
End If
Application.ScreenUpdating = True
ExitHere:
Exit Sub
HandleErr:
Select Case Err.Number
Case Else
MsgBox Err.Description, vbCritical, "Error in DeleteDuplicateRows"
Resume ExitHere
End Select
End Sub