'參考 ikboy 學習System.collections.arraylist
Sub 排名AmoKat修改()
tm = Timer
Dim d As Object, a, k, t, xL As Object, n&
a = Range("h6:h" & [h1048576].End(3).Row)
Set d = CreateObject("scripting.dictionary") '字典取唯一值
For Each k In a: If k <> "" Then d(k) = 0: Next
Set xL = CreateObject("System.collections.arraylist") '排序作業
For Each k In d.keys: xL.Add k: Next
xL.Sort 'Sorted Ascending
xL.Reverse 'Reverse sort
For i = 1 To xL.Count: d(xL(i - 1)) = i: Next '排序序號(排名)寫入字典
For i = 1 To UBound(a)
If a(i, 1) = "" Then a(i, 1) = 0 Else a(i, 1) = d(a(i, 1)) '排名寫入a陣列
Next
[i6].Resize(UBound(a)) = a 'a陣列寫入 I 欄位
Debug.Print Timer - tm, "End" '31.40" 改善為 0.332"
End Sub
Sub 排名AmoKat()
tm = Timer
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([h6], [h1].Cells(Rows.Count, 1).End(xlUp))
For i = 1 To UBound(Arr): xD(Arr(i, 1)) = 0: Next i '字典產生唯一值
With [i6].Resize(xD.Count) '利用 Range.Sort 排序
.Value = Application.Transpose(xD.keys)
.Sort Key1:=.Item(1), Order1:=xlDescending, Header:=xlNo
End With
For i = 1 To xD.Count: xD(Cells(5 + i, "I").Value) = i: Next i '排序序號寫入字典
For i = 1 To UBound(Arr) '查詢字典排列序號
If Arr(i, 1) = "" Then Arr(i, 1) = 0 Else Arr(i, 1) = xD(Arr(i, 1))
Next i
[i6].Resize(UBound(Arr)) = Arr '貼上資料
Set xD = Nothing: Erase Arr
Debug.Print Timer - tm '0.30"
End Sub
發表於 2021-10-19 16:32
| 