Identify unique items in column and delete row

[blackie42]

Hi,

Anyone suggest a macro to identify where there is a unique entry in column A and then delete the whole row?

many thanks
Jon

[Paul_Hossler]

Try this




Option Explicit

Sub Macro1()
Dim rFilter As Range, rVisible As Range
Dim iRow As Long, iArea As Long

Set rFilter = ActiveSheet.Range("A1")
Set rFilter = Range(rFilter, rFilter.End(xlDown))

rFilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=True

Set rVisible = ActiveSheet.Columns(1).SpecialCells(xlCellTypeVisible)
Set rVisible = Intersect(rVisible, ActiveSheet.UsedRange)

ActiveSheet.ShowAllData

For iArea = rVisible.Areas.Count To 1 Step -1
For iRow = rVisible.Areas(iArea).Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountIf(rFilter, rVisible.Areas(iArea).Cells(iRow, 1).Value) = 1 Then
If rVisible.Areas(iArea).Cells(iRow, 1).Row <> 1 Then
rVisible.Areas(iArea).Cells(iRow, 1).EntireRow.Delete
End If

End If
Next iRow
Next iArea

End Sub

[blackie42]

Cheers Paul

Works perfectly

regards
Jon