samwang

回復 5# oak0723-1

1.前後都有數據的空白儲存格-->顯示0,不列入排名
2.數據結束後的空白儲存格-->不列入排名,不作動作,依然是空白
>> 3#程式有符合上述條件，謝謝

samwang

回復 1# oak0723-1

不一樣的解法有比3#再提升一點點效率，請測試看看，謝謝

Sub test2()
Dim Arr, xD, a, T, i&
Set xD = CreateObject("Scripting.Dictionary")
Tm = Timer
Arr = Range("h6:h" & Cells(Rows.Count, 8).End(xlUp).Row)
For i = 1 To UBound(Arr)
    T = Arr(i, 1): If T <> "" Then xD(T) = ""
Next
For i = 1 To xD.Count
    a = Application.Large(xD.keys, i)
    n = n + 1: xD(a) = n
Next
For i = 1 To UBound(Arr)
    T = Arr(i, 1)
    If T = "" Then Arr(i, 1) = 0: GoTo 99
    Arr(i, 1) = xD(T)
99: Next
Range("j6").Resize(UBound(Arr)) = Arr
MsgBox Timer - Tm
End Sub

准提部林

Sub 排名()
Dim Arr, Brr, xD, V&, i&, j&, k&, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([h1], [h1].Cells(Rows.Count, 1).End(3))
ReDim Brr(1 To UBound(Arr) + 1)
For i = 6 To UBound(Arr)
    If Arr(i, 1) = "" Then GoTo i01
    V = Arr(i, 1)
    If xD.Exists(V) Then GoTo i01 Else xD(V) = "": N = N + 1
    For j = N To 1 Step -1
        If V >= Brr(j) Then Brr(j + 1) = Brr(j) Else Exit For
    Next j
    Brr(j + 1) = V
i01: Next i
xD.removeall
For j = 1 To N: xD(Brr(j)) = j: Next
'------------------------------------
For i = 6 To UBound(Arr)
    V = xD(Arr(i, 1))
    If Arr(i, 1) = "" Then V = 0
    Arr(i - 5, 1) = V
Next i
[i6].Resize(UBound(Arr) - 5) = Arr
Set xD = Nothing: Erase Arr, Brr
End Sub


=====================================

oak0723-1

回復 13# 准提部林


    謝謝關注
感謝熱心回復

oak0723-1

回復 12# samwang


    確實速度有變得更快
非常感謝
對我幫助非常大

oak0723-1

回復 11# samwang


    是的
都有符合
因為發現時文章已超過15分鐘
無法刪除
所以很對不起

oak0723-1

回復 13# 准提部林


    想利用事件觸發排名巨集
當 H 欄內容改變就觸發執行"排名teat02"巨集
如何使用事件觸發?
若不用事件觸發,要如何觸發?

准提部林

回復 17# oak0723-1


Private Sub Worksheet_Change(ByVal Target As Range)
With Target
     If .Column <> [h1].Column Then Exit Sub
     If .Row < 6 Or .Count > 1 Then Exit Sub
     Call 排名test02
End With
End Sub

資料量大的話, 少用事件觸發, 數據完成後用按鈕較適妥

oak0723-1

回復 18# 准提部林


    謝謝你

ML089

'參考 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