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