Question

Currently I have a macro that runs through a list and deletes duplicate values (in one column), but it’s proving to be very inefficient. For every entry that it checks for duplicates, it has to run through the whole column; my file currently has 50,000 entries and that is no small task.

I think an easier way for the macro to work is for the macro to check if this value is in an array. If it is, then remove the row that the entry is in. If it isn’t, add the value to the array.

Can someone provide some help with the basic outline of the macro? Thanks

Answer 1

The Below code will loop through your source data and store it in an array, while simultaneously checking for duplicates. After the collection is complete it uses the array as a key to know which columns to delete.

Due to the high number of potentiol screen updates with the deletion be sure to turn screenupdating off. (included)

Sub Example()
    Application.ScreenUpdating = false
    Dim i As Long
    Dim k As Long
    Dim StorageArray() As String
    Dim iLastRow As Long
    iLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

    ReDim StorageArray(1 To iLastRow, 0 To 1)

    'loop through column from row 1 to the last row
    For i = 1 To iLastRow
        'add each sheet value to the first column of the array
        StorageArray(i, 0) = ActiveSheet.Range("A" & i).Value
        '- keep the second column as 0 by default
        StorageArray(i, 1) = 0
        '- as each item is added, loop through previously added items to see if its a duplicate
        For k = 1 To i-1
            If StorageArray(k, 0) = StorageArray(i, 0) Then
                'if it is a duplicate set the second column of the srray to 1
                StorageArray(i, 1) = 1
                Exit For
            End If
        Next k
    Next i

    'loop through sheet backwords and delete rows that were maked for deletion
    For i = iLastRow To 1 Step -1
        If StorageArray(i, 1) = 1 Then
            ActiveSheet.Range("A" & i).EntireRow.Delete
        End If
    Next i

    Application.ScreenUpdating = true
End Sub

---

As requested, here is a similar way to do it, using Collections instead of an Array for key indexing: (RBarryYoung)

Public Sub RemovecolumnDuplicates()
    Dim prev as Boolean
    prev = Application.ScreenUpdating
    Application.ScreenUpdating = false
    Dim i As Long, k As Long

    Dim v as Variant, sv as String
    Dim cl as Range, ws As Worksheet
    Set ws = ActiveWorksheet    'NOTE: This really should be a parameter ...

    Dim StorageArray As New Collection
    Dim iLastRow As Long
    iLastRow = ws.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

    'loop through column from row 1 to the last row
    i = 1
    For k = 1 To iLastRow
        'add each sheet value to the collection
        Set cl = ws.Cells(i, 1)
        v = cl.Value
        sv = Cstr(v)

        On Error Resume Next
            StorageArray.Add v, sv
        If Err.Number <> 0 Then
            'must be a duplicate, remove it
            cl.EntireRow.Delete
            'Note: our index doesn't change here, since all of the rows moved
        Else
            'not a duplicate, so go to the next row
            i = i + 1
        End If
    Next k

    Application.ScreenUpdating = prev
End Sub

Note that this method does not need to assume any datatype or integer limits for the values of the cells in the column.

(Mea Culpa: I had to hand-enter this in Notepad, because my Excel is busy running project tests right now. So there may be some spelling/syntax errors…)