Try the following. This is basically registered and a bit fine-tuned (for instance checking if any row is visible after autofilter):
Sub test()
Dim lastrow As Long
Application.ScreenUpdating = False
'remove duplicates with the same card, customer and account
ActiveSheet.Range("Table18[#All]").RemoveDuplicates Columns:=Array(3, 5, 6), Header:=xlYes
' sort descending on serial (to keep from both duplicates the one with higher serialNo
ActiveSheet.ListObjects("Table18").Sort.SortFields.Clear
ActiveSheet.ListObjects("Table18").Sort.SortFields.Add _
Key:=Range("Table18[[#All],[SerialNo]]"), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Problem").ListObjects("Table18").Sort
.Header = xlYes
.Orientation = xlTopToBottom
.Apply
End With
' now remove duplicates (match customer ID and Account ID.
ActiveSheet.Range("Table18[#All]").RemoveDuplicates Columns:=Array(3, 6), Header:=xlYes
'sort back
ActiveSheet.ListObjects("Table18").Sort.SortFields.Clear
ActiveSheet.ListObjects("Table18").Sort.SortFields.Add _
Key:=Range("Table18[[#All],[SerialNo]]"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.ListObjects("Table18").Sort
.Header = xlYes
.Orientation = xlTopToBottom
.Apply
End With
' 2) empty cardnumbers autofilter and delete whole rows
lastrow = ActiveSheet.ListObjects("Table18").Range.Rows.Count + 1 'you have aempty wow above table
ActiveSheet.ListObjects("Table18").Range.AutoFilter Field:=5, Criteria1:="="
If ActiveSheet.Range("A2:A" & lastrow).SpecialCells(xlCellTypeVisible).Count > 1 Then
Rows("3:" & lastrow).Delete Shift:=xlUp
End If
ActiveSheet.ListObjects("Table18").Range.AutoFilter Field:=5
End Sub
Bookmarks