Board logo

標題: 大量資料排名 [打印本頁]
作者: oak0723-1    時間: 2021-9-27 21:46     標題: 大量資料排名

各位先進好
我想要把H欄位裡排名顯示在J欄
但因為資料太多常常會有達50萬個數字(資料數不一定)
用函數方式處理常常會當掉
不知如何改成VBA的方式自動計算
函數式:"=IF(H6="",0,SUMPRODUCT(($H$6:$H$500000>=H6)*(1/COUNTIF(H$6:H$500000,H$6:H$500000))))"
作者: ikboy    時間: 2021-9-28 08:34

  1. Sub zz()
  2. Dim d As Object, a, k, t, xL As Object, n&
  3. Set xL = CreateObject("System.collections.arraylist")
  4. Set d = CreateObject("scripting.dictionary")
  5. a = Range("h6:h" & [h1048576].End(3).Row)
  6. For Each k In a
  7.     d(k) = ""
  8. Next
  9. For Each k In d.keys
  10.     xL.Add k
  11. Next
  12. xL.Sort: b = xL.Toarray()
  13. n = UBound(b)
  14. For i = 1 To UBound(a)
  15.     For j = 0 To n
  16.         If a(i, 1) <= b(j) Then a(i, 1) = n + 1 - j: Exit For
  17.     Next
  18. Next
  19. [i6].Resize(i - 1) = a
  20. End Sub
複製代碼
作者: samwang    時間: 2021-9-28 08:35

回復 1# oak0723-1

請測試看看，謝謝
Sub test()
Dim Arr, Brr, xD, T
Set xD = CreateObject("Scripting.Dictionary")
With Range("h6:h" & Cells(Rows.Count, 8).End(xlUp).Row)
    Brr = .Value
    .Sort key1:=.Item(1), Order1:=2, Header:=2
    Arr = .Value
    .Value = Brr
End With
For i = 1 To UBound(Arr)
    T = Arr(i, 1): If T = "" Then GoTo 98
    If xD(T) = "" Then: n = n + 1: xD(T) = n
98: Next
For i = 1 To UBound(Brr)
    T = Brr(i, 1)
    If T = "" Then Brr(i, 1) = 0: GoTo 99
    Brr(i, 1) = xD(T)
99: Next
Range("i6").Resize(UBound(Brr)) = Brr
End Sub
作者: samwang    時間: 2021-9-28 14:09

回復 1# oak0723-1


請問H欄數值空白時(不是0)， 排名為 0嗎?
作者: oak0723-1    時間: 2021-9-28 20:56

回復 4# samwang


    抱歉我沒描述清楚
內容空白有2種情形
1.前後都有數據的空白儲存格-->顯示0,不列入排名
2.數據結束後的空白儲存格-->不列入排名,不作動作,依然是空白
作者: oak0723-1    時間: 2021-9-28 21:16

回復 3# samwang


    你好,感謝你願意熱心協助
我執行後發現

不重新開啟檔案情況下更動數據後再執行程式,發現執行速度會更慢檔案更容易當機
作者: oak0723-1    時間: 2021-9-28 21:20

回復 2# ikboy
你好
謝謝你的熱心協助
這個程式在重複執行,就是不關閉重新開啟,而直接更改數據,使用新的1組數據(內容和數據數量都不同)再執行,速度會更慢更容易當機
作者: ikboy    時間: 2021-9-29 00:15

回復 7# oak0723-1


    是否你本身的公式導致? 可改為手動重算試試。
作者: samwang    時間: 2021-9-29 08:32

回復 6# oak0723-1

移除J6 公式再執行程式就可以，請測試看看，謝謝
作者: oak0723-1    時間: 2021-9-29 09:59

回復 9# samwang


    原來是j6公式卡住整體的運算
謝謝你
作者: samwang    時間: 2021-9-29 10:11

回復 5# oak0723-1

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

回復 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
作者: 准提部林    時間: 2021-10-2 10:38

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    時間: 2021-10-2 21:46

回復 13# 准提部林


    謝謝關注
感謝熱心回復
作者: oak0723-1    時間: 2021-10-2 21:48

回復 12# samwang


    確實速度有變得更快
非常感謝
對我幫助非常大
作者: oak0723-1    時間: 2021-10-3 05:44

回復 11# samwang


    是的
都有符合
因為發現時文章已超過15分鐘
無法刪除
所以很對不起
作者: oak0723-1    時間: 2021-10-11 16:47

回復 13# 准提部林


    想利用事件觸發排名巨集
當 H 欄內容改變就觸發執行"排名teat02"巨集
如何使用事件觸發?
若不用事件觸發,要如何觸發?
作者: 准提部林    時間: 2021-10-15 13:54

回復 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    時間: 2021-10-17 17:07

回復 18# 准提部林


    謝謝你
作者: ML089    時間: 2021-10-19 16:32

'參考 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
作者: ML089    時間: 2021-10-19 16:42

本帖最後由 ML089 於 2021-10-19 16:44 編輯

10萬筆資料，唯一值有1萬筆，排名比較
排序採用 Range.Sort   執行時間  0.3"
排序採用 System.collections.arraylist    執行時間  0.33"
排序採用 Large函數 執行時間 30"
結論 Range.Sort 也不慢

原資料10萬筆只有6筆是唯一值，這樣測不出效率，
其實唯一值小於10筆用函數也可以 0.3"，唯一值為1萬筆需要46秒

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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)