sort column based on number of duplicate values

Hello all,

I have countries listed in Column D with many duplicates. My goal is to sort Column D, from highest to lowest, based on the number of duplicates:

So, this:

Country
US
US
US
US
UK
UK
Italy
Italy
Italy
Italy
Italy
Italy

would become this:
Italy
Italy
Italy
Italy
Italy
Italy
US
US
US
US
UK
UK

The following code works, but is very slow (I have 20,000+ rows of data). Are there any faster alternatives?

(Note: I have data in column A which I use to define the last row of data -LR-)

Sub Macro1()
'
' Macro1 Macro

Dim LR As Long

LR = Range("A" & Rows.Count).End(xlUp).Row
Columns("E:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("E2").FormulaR1C1 = "=COUNTIF(C[-1],RC[-1])"
Range("E2").AutoFill Destination:=Range("E2", "E" & LR)
    
ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range( _
     "E2", "E" & LR), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
     xlSortNormal
With ActiveWorkbook.Worksheets("sheet1").Sort
     .SetRange Range("A1", "Z" & LR)
     .Header = xlYes
     .MatchCase = False
     .Orientation = xlTopToBottom
     .SortMethod = xlPinYin
     .Apply
End With




End Sub

Thanks, AndyLitch. This works, but is not really speeding things up for me. I see that you are setting the application.calculation to xlmanual. Should that speed things up?

Thanks you AndyLitch. I have added the Application.ScreenUpdating in addition to the manual application.calculation. It still isn't quite instantaneous, but given the nature of problem, perhaps this is as fast as I should expect it to run. Thanks for the help!

Awesome. Thanks again.