VBA to move all duplicates to another tab

[KGards7]

Hi all,

I have a button that runs the below code:

Sub KGards7()
Dim lr, k As Long
lr = Range("A" & Rows.Count).End(xlUp).Row
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")

For k = lr To 1 Step -1
If dic.Exists(Range("A" & k).Value) = False Then
dic(Range("A" & k).Value) = k
Else: Range("A" & k).EntireRow.Delete
End If
Next k

End Sub

Basically it searches column A locates all duplicates and only keeps the most recent one and deletes the whole row of any of the now outdated duplicates.

My issue is this runs on an Excel document where there are vast quantities of data so to complete it can take on times close to an hour.

Is there a way I can click this button to cut and paste out the duplicates into a new tab, then run the above code on the new tab and then paste the results back into the main tab?

Alternatively if you have another solution so the above code can run faster then I'm open to any and all suggestions.

Thank you, I appreciate your time and help!

 

[Fluff]

similar code, get alternative

But considerably slower about 6 secs compared to 0.3 secs, on some test data I've got.

 

[veyselemre]

You are right. It can take a long time to delete lines from between. This code may take less time.

Sub test()

    Dim rng As Range, i&, ky$, sec(1 To 3), lst, lr&
    With Application
        sec(1) = .ScreenUpdating: .ScreenUpdating = False
        sec(2) = .EnableEvents: .EnableEvents = False
        sec(3) = .Calculation: .Calculation = xlCalculationManual
    End With
    lr = Cells(Rows.Count, 1).End(3).Row
    Set rng = Range("A2:A" & lr)
    lst = rng.Value

    With CreateObject("Scripting.Dictionary")
        For i = UBound(lst) To 1 Step -1
            ky = lst(i, 1)
            If Not .Exists(ky) Then
                .Item(ky) = ""
            Else
                lst(i, 1) = ""
            End If
        Next i
    End With
    rng.Value = lst

    If WorksheetFunction.CountBlank(rng) Then
        rng.Sort rng.Cells(1)
        Range(rng.End(xlDown).Offset(1), rng.Cells(rng.Cells.Count)).EntireRow.ClearContents
    End If

    With Application
        .ScreenUpdating = sec(1)
        .EnableEvents = sec(2)
        .Calculation = sec(3)
    End With

    Beep
End Sub

 

[Fluff]

That is faster, but if there is more than one column it will destroy the data as it is only sorting the 1st column & leaving the rest of the data alone.

 

[veyselemre]

You are right again. It was on my mind, I skipped it.

Sub test()

    Dim rng As Range, i&, ky$, sec(1 To 3), lst, lr&
    With Application
        sec(1) = .ScreenUpdating: .ScreenUpdating = False
        sec(2) = .EnableEvents: .EnableEvents = False
        sec(3) = .Calculation: .Calculation = xlCalculationManual
    End With
    lr = Cells(Rows.Count, 1).End(3).Row
    Set rng = Range("A2:A" & lr)
    lst = rng.Value

    With CreateObject("Scripting.Dictionary")
        For i = UBound(lst) To 1 Step -1
            ky = lst(i, 1)
            If Not .Exists(ky) Then
                .Item(ky) = ""
            Else
                lst(i, 1) = ""
            End If
        Next i
    End With
    rng.Value = lst

    If WorksheetFunction.CountBlank(rng) Then
        rng.CurrentRegion.Sort rng.Cells(1)
        Range(rng.End(xlDown).Offset(1), rng.Cells(rng.Cells.Count)).EntireRow.ClearContents
    End If

    With Application
        .ScreenUpdating = sec(1)
        .EnableEvents = sec(2)
        .Calculation = sec(3)
    End With

    Beep
End Sub