Sort process takes too long with large data

[YasserKhalil]

Hello everyone
I have a code that copy the contents of sheet to another sheet then sort the data in custom way based on column C and then based on dates in column D
The code is working well with small amounts of data

Code: Select all

Sub Test()
    Dim a, x, dic As Object, lr As Long, i As Long, n As Long
    Const sOutput As String = "Output"
    Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        On Error Resume Next: Sheets(sOutput).Delete: On Error GoTo 0
        Application.DisplayAlerts = True
        Sheets("Sheet1").Copy , Sheets(Sheets.Count)
        Sheets(Sheets.Count).Name = sOutput
        With Sheets(sOutput)
            lr = .Cells(Rows.Count, 1).End(xlUp).Row
            .Columns("A:B").Delete
            Set dic = CreateObject("Scripting.Dictionary")
            a = .Range("A1").CurrentRegion.Columns(1).Value
            For i = LBound(a) + 1 To UBound(a)
                If a(i, 1) <> "" Then dic(a(i, 1)) = Empty
            Next i
            x = dic.Keys
            n = Application.CustomListCount
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("A1"), CustomOrder:=Join(x, ",") & vbNullString
                .SortFields.Add Key:=Range("B1"), Order:=xlDescending
                .SetRange Range("A1").CurrentRegion
                .Header = xlYes
                .Apply
                .SortFields.Clear
            End With
            With .Range("E2:E" & lr)
                .Formula = "=COUNTIF($A$2:A2,A2)"
                .Value = .Value
            End With
            With .Range("A1").CurrentRegion
                .AutoFilter 5, ">" & 1
                 .Offset(1).EntireRow.Delete
                .AutoFilter
                .Columns(5).Clear
            End With
        End With
    Application.ScreenUpdating = True
End Sub

When trying the code on large amounts of data, it takes more over 6 minutes (about 150,000 rows)
You can run the code to test the results. The results will be one record for each unqiue number in column C (the most recent date for that number)
Any ideas?

[HansV]

I added some timers to the code and tested it with 414000 rows of data. The macro took 55 seconds on my PC. The part that took longest was not the sorting (that took only 2 seconds), but this one:

Code: Select all

        With .Range("E2:E" & lr)
            .Formula = "=COUNTIF($A$2:A2,A2)"
            .Value = .Value
        End With

That took 48 of the 55 seconds.
You can replace

Code: Select all

        With .Range("E2:E" & lr)
            .Formula = "=COUNTIF($A$2:A2,A2)"
            .Value = .Value
        End With
        With .Range("A1").CurrentRegion
            .AutoFilter 5, ">" & 1
             .Offset(1).EntireRow.Delete
            .AutoFilter
            .Columns(5).Clear
        End With

with

Code: Select all

        .UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes

That is many times faster!

[YasserKhalil]

Thank you very much my tutor