Delete duplicate rows based on part of cell.

[okrob]

How to delete rows based on part of cell. Given that Column A:A is the
only one populated on a worksheet and you want to delete duplicates
based only on the first 4 characters of the cells in the column.
Some slight modification would be necessary if there is data in any of
the other columns (B and C).
Just thought I'd throw it out there. I needed it, and didn't see what
I needed. Thanks to this news group for the basic routine.

Rob


Sub delete_rows_based_on_cell_part()
Dim x as integer
Dim y As Long
Dim number As Long
Dim value As Variant
Dim rng As Range
On Error GoTo EndMacro
Application.ScreenUpdating = False
x = 4 '<=== Change this value to suit.
Dim rRow()
nrows = ActiveSheet.UsedRange.Rows.Count
ReDim rRow(nrows)
Columns("A:A").Insert Shift:=xlToRight
Range("A1").FormulaR1C1 = "=LEFT(RC[1],x)"
Range("A1").AutoFill Destination:=Range("A1:A" & nrows)
Range("D1").Formula = "=A1&C1"
Range("D1").Copy
Range("D2" & nrows).PasteSpecial xlPasteFormulas
Set rng = ActiveSheet.UsedRange.Rows
number = 0
For y = rng.Rows.Count To 1 Step -1
value = rng.Cells(y, 4).Value
If Application.WorksheetFunction.CountIf(rng.Columns(4), value) >
1 Then
rng.Rows(y).EntireRow.Delete
number = number + 1
End If
Next y
' Says CountIf any cell in col A = this cell in col D.
' Then if the count > 1 delete the row. Loop entire range.
Columns(1).Delete
Columns(3).Delete
' Get rid of the extra columns

Columns(1).SpecialCells(xlBlanks).EntireRow.Delete
' Just in case... You don't have to delete the blank rows, but I did.

Application.ScreenUpdating = True
Exit Sub

EndMacro:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub