Create Unique List in Shortest Time

[modytrane]

I have a list of project numbers that is over 7000 rows long [example attached].
Many numbers are repeated. This list comes out of a financial reporting system.
I need to extract a list of unique numbers in numerical order.
I have two solutions working, one with SUMPRODUCT formulas and one with MACRO.
Here's the MACRO solution.
But it takes about 20 seconds to execute.
I am just looking to cut down on execution time. I am using this macro a few times on different lists in the same program.

Is there a better [faster] way to do this?

Sub UniqueOrder()
Sheets("Sheet1").Select
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False
Application.EnableEvents = False

For i = LR To 2 Step -1
    If WorksheetFunction.CountIf(Columns("A:A"), Cells(i, "A")) > 1 Then _
                         Rows(i).EntireRow.Delete Shift:=xlUp
Next i
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Thanks for any helpful hints.
modytrane

[romperstomper]

Using the Advanced filter with the Unique records option checked is probably the fastest way to do it.

[DonkeyOte]

echoing romperstomper... re: Advanced Filter

on an aside bear in mind that deletion of rows is a Volatile action so normally a good idea to set Calc to Manual beforehand and reset to original setting thereafter:

Sub UniqueOrder()
Dim LR As Long, i As Long
Dim xlCalc as xlCalculation
LR = Cells(Rows.Count,"A").End(xlUp).Row
With Application
    xlCalc = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    For i = LR To 2 Step -1
        If .CountIf(Columns("A:A"), Cells(i, "A")) > 1 Then Rows(i).EntireRow.Delete
    Next i
    .calculation = xlCalc
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

[Andy Pope]

Should see an increase with this

Sub UniqueOrder2()

    Sheets("Sheet1").Select
    Dim LR As Long
    Dim lngRow As Long
    Dim strLastID As String
    Dim lngLastRow As Long
    
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    LR = Range("A" & Rows.Count).End(xlUp).Row
    strLastID = Cells(LR, 1).Value
    lngLastRow = LR - 1
    
    For lngRow = LR To 1 Step -1
        If Cells(lngRow, 1).Value <> strLastID Then
            If lngLastRow - lngRow > 0 Then
                Range(Cells(lngRow + 1, 1), Cells(lngLastRow, 1)).EntireRow.Delete shift:=xlUp
            End If
            strLastID = Cells(lngRow, 1)
            lngLastRow = lngRow - 1
        End If
    Next
    Application.ScreenUpdating = True
    Application.EnableEvents = True

End Sub

[modytrane]

Thanks Andy,
That routine works great.
It speeds up the process significantly.
Thank You,
modytrane.