delete duplicate rows based on two column names

[boiboi]

Hi,

Can anyone help with below? My code is running for around 5 minutes or more with data of only 10 records in the worksheet.

Dim nameCol As Range
Dim aCell As Range
Dim Cell As Range
Dim Cel As Range, N&
N = 0


Set nameCol = .Range("A1:AU1").Find("apple")
Set aCell = .Range("A1:AU1").Find("orange")

Application.Union(nameCol, aCell).EntireColumn.Select

For Each Cell In Selection
If Cell <> Empty Then
For Each Cel In Selection
If Cel <> Empty And _
Cel.Value = Cell.Value And _
Cel.Address <> Cell.Address Then
Cel.EntireRow.Delete
N = N + 1
End If
Next Cel
End If
Next


Much appreciated in advance.

 

[boiboi]

1. if i add two more duplicate rows at bottom:
kiwi grape mango apple durian pineapple tomato orange coconut


red red
red red

it will not be highlighted.

2. after adding/editing several duplicate rows in Sheet2, the duplicate rows are not highlighted as well.

 

[Fluff]

Did you run the macro again after editing the data?

 

[boiboi]

yes, still same, nothing happens to the new edits.

https://www.dropbox.com/s/lf58u8kusydbitt/fruits.xlsm?dl=0

 

[Fluff]

The code is looking at col A to determine the last row of data and as that is blank for the added rows they don't get highlighted.

 

[boiboi]

Anyway to look at dynamic column name to determine last row, instead of fixing at col A?

 

[Fluff]

Try

Sub Color_All_Dupes_Not_First()
Dim c As Range, a() As String, i As Long, n As Long, x As String, j As Long
Dim lr As Long, ffc As Long, fr1 As Long, fr2 As Long
ffc = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
fr1 = Rows(1).Find("apple", , , 1).Column
fr2 = Rows(1).Find("orange").Column
Application.ScreenUpdating = False
lr = Cells(Rows.Count, fr1.col).End(xlUp).Row

With Range(Cells(2, ffc), Cells(lr, ffc))
    .Formula = "=RC[-" & ffc - fr1 & "]&RC[-" & ffc - fr2 & "]"
    .Value = .Value
End With

n = 1
ReDim a(1 To n)
    a(1) = Cells(2, ffc).Value
    i = 3
    While Not IsEmpty(Cells(i, ffc))
        x = Cells(i, ffc).Value
        If IsError(Application.Match(x, a, 0)) Then
            n = n + 1
            ReDim Preserve a(1 To n)
            a(n) = x
        End If
        i = i + 1
    Wend

For j = LBound(a) To UBound(a)
    For Each c In Range(Cells(2 + WorksheetFunction.Match(a(j), Range(Cells(2, ffc), Cells(lr, ffc)), 0), ffc), Cells(lr, ffc))
        If c.Value = a(j) Then c.EntireRow.Interior.Color = vbYellow
    Next c
Next j

Columns(ffc).ClearContents
Application.ScreenUpdating = True
End Sub

 

[boiboi]

i got error "Invalid qualifier"

 

[Fluff]

Oops, it should be

lr = Cells(Rows.Count, fr1).End(xlUp).Row

 

[boiboi]

https://www.dropbox.com/s/lf58u8kusydbitt/fruits.xlsm?dl=0

duplicate rows in Sheet1 are not highlighted

 

[boiboi]

https://www.dropbox.com/s/lf58u8kusydbitt/fruits.xlsm?dl=0

i got unable to get the match property error.