Deleting Duplicate Rows

[Jared_Jones_23]

I have a code that checks certain columns in different rows to see if they are considered a duplicate then deletes them. The problem is I have about 15 columns that need checked and im wondering if it check through an array of those columns. Heres my code and array.
Any suggestions are appreciated, thank you,
Jared

The array of columns is myarray=array(1,2,8,12,14,15,16,18,20,21,22,23,24,25,28)

Sub rows()
'using nested do while loops
'we start at row 20 because row 19 has only the headers
x = 20
y = x + 1
Do While Cells(x, 1).Value <> ""
Do While Cells(y, 1).Value <> ""
If Cells(x, 1).Value = Cells(y, 1).Value And Cells(x, 2) = Cells(y, 2).Value And Cells(x, 8) = Cells(y, 8) ... (Instead of individually checking every cell i would like to loop through my array here)
'delete if duplicate
Cells(y, 1).EntireRow.Delete
Else
y = y + 1
End If
Loop
x = x + 1
y = x + 1
Loop
End Sub

 

[Weaver]

So would the values in all the columns have to be identical to be considered duplicate?

One way might be to compare the average value of all the cells to the max value of all the cells, since if all the values are the same, so these two values will be the same.

Not tested:

Sub dupeCheck()
    Dim lr As Long, colRange As Range
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    myarray = Array(1, 2, 8, 12, 14, 15, 16, 18, 20, 21, 22, 23, 24, 25, 28)
    For Each i In myarray
        If colRange Is Nothing Then
            Set colRange = Columns(i)
        Else
            Set colRange = Union(colRange, Columns(i))
        End If
    Next i
    For x = lr To 20 Step -1
        If WorksheetFunction.Average(Intersect(colRange, Rows(x))) = _
            WorksheetFunction.Max(Intersect(colRange, Rows(x))) Then
            Rows(x).EntireRow.Delete
        End If
    Next x
End Sub

Of course, this approach won't work if it's text, but I'm sure it can be adapted.

 

[Weaver]

I have a solution to text, but need to know what counts as 'duplicate'. Do all of them have to be the same or at least 1 matching pair?

 

[Jared_Jones_23]

Every Column in the array would have to match to be considered a duplicate. If some of them are the same but not all then they would not be considered a duplicate. Thank you

 

[Weaver]

Okay, try this then:

Note: Please run on a copy of your data!

Sub dupeCheck()
    Dim lr As Long, colRange As Range
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    myarray = Array(1, 2, 8, 12, 14, 15, 16, 18, 20, 21, 22, 23, 24, 25, 28)
    Application.ScreenUpdating = False
    For Each i In myarray
        If colRange Is Nothing Then
            Set colRange = Columns(i)
        Else
            Set colRange = Union(colRange, Columns(i))
        End If
    Next i
    For x = lr To 20 Step -1
        If allDupes(Intersect(colRange, Rows(x))) Then
            Rows(x).EntireRow.Delete
        End If
    Next x
End Sub

Function allDupes(ByVal rng As Range) As Boolean
    With CreateObject("scripting.dictionary")
        For Each o In rng.Cells
            If Not .exists(o.Value) Then
                .Add o.Value, 1
            End If
        Next
        allDupes = (.Count = 1)
    End With
End Function

 

[Jared_Jones_23]

That code seems to work but it takes a very long time to run. It is starting down at row 6601 something and working its way up one line at a time. After about 3 minutes of running its only up to row 6518.

 

[kpark91]

Hi Jared_Jones. Is it ok to sort the data?
If you are allowed, how long does it take to sort them? (approximate)

 

[Jared_Jones_23]

I will have to check although I would assume sorting it is fine. Sorting it took about 15 seconds.

 

[Weaver]

That code seems to work but it takes a very long time to run. It is starting down at row 6601 something and working its way up one line at a time. After about 3 minutes of running its only up to row 6518.

Which version are you using?Also, which version of Excel? Do you have other sheets open at the same time?

 

[Jared_Jones_23]

I am using Excel 2007 on windows 7. I only have other worksheets open in the same workbook. Besides those nothing else is open.