CODEWITHSUNDEEP
vbaexcel
Gonax10
Gonax10

Reputation: 21

Clear(Not Delete) Duplicates and keep first entry using VBA

I would like to clear all the duplicates values in the first column of my table but keeping the first entry.

If my table is like the following example:

    A          B          C
    001        Katy   Argentina
    002        Katy   Argentina
               Katy   Argentina
    002        Katy   Argentina
    004        Katy   Argentina
    001        Katy   Argentina

The desired result:

    A          B          C
    001        Katy   Argentina
    002        Katy   Argentina
               Katy   Argentina
               Katy   Argentina
    004        Katy   Argentina
               Katy   Argentina

My first solution was creating a new column with a Countif Formula like this:

=IF(COUNTIF($A$1:A1,A1)=1,A1,"")

This is working really well but my table contains several columns and 300,000 rows so when I run this process it takes about 3 hours.

Is it possible to run this with VBA?

Upvotes: 0

Views: 4370

Answers (2)

Tim Williams
Tim Williams

Reputation: 166306

This is pretty fast:

Sub Tester()
    Dim t
    'create some repeating data
    With Range("A2:A300000")
        .Formula = "=ROUND(RAND()*1000,0)"
        .Value = .Value
    End With

    t = Timer
    ClearDups Range("A2:A300000")  'remove the dups
    Debug.Print Timer - t & " sec"  ' < 1sec
End Sub


Sub ClearDups(rng As Range)
    Dim data, dict As Object, r As Long, nR As Long, tmp
    Set dict = CreateObject("scripting.dictionary")

    Set rng = rng.Columns(1) 'make sure only one column...
    data = rng.Value      'grab data in an array
    nR = UBound(data, 1)
    'loop over the array
    For r = 1 To nR
        tmp = data(r, 1)
        If Len(tmp) > 0 Then
        If dict.exists(tmp) Then
            data(r, 1) = "" 'seen this value before - clear it
        Else
            dict.Add tmp, 1  'first time for this value
        End If
        End If
    Next r
    rng.Value = data 'dump the array back to the range
End Sub

Upvotes: 2

Gary&#39;s Student
Gary&#39;s Student

Reputation: 96753

Consider:

Sub ClearV()
    Dim N As Long
    N = Cells(Rows.Count, "A").End(xlUp).Row
    For i = N To 2 Step -1
        Set rlook = Range(Cells(i - 1, "A"), Cells(1, 1))
        If Application.WorksheetFunction.CountIf(rlook, Cells(i, "A")) > 0 Then
            Cells(i, "A").Clear
        End If
    Next i
End Sub

Upvotes: 2

Related Questions