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.

 

[Fluff]

Are you trying to delete any row where the value in the two columns is the same?

 

[boiboi]

i'm trying to delete any row (except the first original row, which is not duplicate yet) where the value in the two columns is the same

 

[Fluff]

How about

Sub boiboi()
   Dim Fnd1 As Range, Fnd2 As Range, Cl As Range, Rng As Range
   
   Set Fnd1 = Range("1:1").Find("apple", , , xlWhole, , , False, , False)
   Set Fnd2 = Range("1:1").Find("orange", , , xlWhole, , , False, , False)
   If Fnd1 Is Nothing Then Exit Sub
   If Fnd2 Is Nothing Then Exit Sub
   For Each Cl In Range(Fnd1.Offset(1), Cells(Rows.Count, Fnd1.Column).End(xlUp))
      If Cl.Value = Cells(Cl.Row, Fnd2.Column) Then
         If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
      End If
   Next Cl
   If Not Rng Is Nothing Then Rng.EntireRow.Delete
End Sub

 

[boiboi]

hi,

after pasting above code, i'm not sure why after clicking run, there is no reaction from excel.

is there any way i can email you the workbook (very small)?

 

[Fluff]

Please do not offer to share workbooks privately, as it is against board policy.
Everything needs to remain on the thread for all members to see.
If you want to share your workbook, you will need to upload to a share site such as OneDrive, DropBox, GoogleDrive, mark for sharing & post the link to the thread.

 

[boiboi]

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

 

[jolivanes]

With a help column (which will be deleted)
Colors the dups.

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
lr = Cells(Rows.Count, 1).End(xlUp).Row
ffc = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
fr1 = Rows(1).Find("apple", , , 1).Column
fr2 = Rows(1).Find("orange").Column
Application.ScreenUpdating = False

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

When posting code, use code tags please. [ code ] (without spaces) at the beginning and [ /code ] (without spaces) at the end

 

[boiboi]

hi jolivanes,


appreciate your reply.

after testing your code above:

1. if i fill in the only both columns with data at bottom (continuing from the end of previous attachment):

kiwi	mango	apple	banana	pineapple	orange	coconut
		abc			abc
		abc			def
		def			abc
		ghi			abc
		abc			abc
		abc			abc
		abc			def

<colgroup><col width="64" span="7" style="width:48pt"> </colgroup><tbody>
</tbody>

the duplicates were not highlighted.

2. After creating another sheet in same workbook, i filled in below, but only the original row is highlighted & not the duplicates:

kiwi	mango	apple	banana	pineapple	orange	coconut
		abc			abc
		abc			def
		def			abc
		ghi			abc
		abc			abc
		abc			abc
		abc			def

<colgroup><col width="64" span="7" style="width:48pt"> </colgroup><tbody>
</tbody>

 

[boiboi]

Moreover, if i edited the cells to change it to become a non-duplicate row afterwards & re-run the macro, the highlights does not adapt:

apple pineapple orange
1 abc a
2 abc b
3 abc a
4 abc b
5 abc a
5 abc b
5 abc @
8 abc b
9 abc a
11 abc b

13 abc b
14 abc b
14 abc b
14 abc @