Hỏi về thuật toán sắp xếp theo thứ tự giảm dần và theo tần suất

[Verona]

Mình cần sắp xếp các giá trị trong mảng dưới đây theo tứ tự giảm dần và lấy theo tần suất. Mình có viết 1 macro, với từng cột thì nó chạy nhanh nhưng nếu chạy cả mảng thì rất chậm vì mảng số liệu của mình gần 18000 số . Mong các bạn giúp
thx

File đính kèm
http://www.mediafire.com/download.php?uymaaexaqya

 

[hoangdanh282vn]

Mình cần sắp xếp các giá trị trong mảng dưới đây theo tứ tự giảm dần và lấy theo tần suất. Mình có viết 1 macro, với từng cột thì nó chạy nhanh nhưng nếu chạy cả mảng thì rất chậm vì mảng số liệu của mình gần 18000 số . Mong các bạn giúp
thx

File đính kèm
http://www.mediafire.com/download.php?uymaaexaqya

bạn xem code này thử

Sub Sapxep()
Dim i As Long, C As Long, R As Long, m As Long
Dim Vung As Range
Application.ScreenUpdating = False
[A1:B65536].Clear
With Sheets("DATA")
    C = .[IV3].End(xlToLeft).Column - 1
    R = .[A65536].End(xlUp).Row
    Set Vung = .Range("A3:A" & R)
    [B1] = "Sapxep"
    Vung.Copy Destination:=[B2]
    m = [B65536].End(xlUp).Row + 1
    For i = 1 To C
        Vung.Offset(, i).Copy Destination:=Cells(m, 2)
        m = [B65536].End(xlUp).Row + 1
    Next
End With
Range("B1:B" & m - 1).AdvancedFilter Action:=xlFilterCopy, _
    copyToRange:=[A1], Unique:=True
[B1:B65536].Clear
[A2:A65536].Sort key1:=[A2], order1:=xlAscending
Application.ScreenUpdating = False
Set Vung = Nothing
End Sub