samwang

回復  samwang

抱歉,漏了1個問題
1.輸入欄位若是空白,就不比對,所得的值就是0(如圖)
2.輸入欄位若是 ...
oak0723-1 發表於 2022-5-21 16:57

是這樣嗎?修改如下紅框， 請確認，謝謝
                If T1 = "" Then
                    Brr(i - 2, j) = 0
                ElseIf T1 = "0" Then
                    Brr(i - 2, j) = ""
                ElseIf T1 = T Then
                    Brr(i - 2, j) = 1: n = n + 1
                ElseIf T1 <> T Then
                    Brr(i - 2, j) = 0
                End If

singo1232001

'若沒問題的話  這個有稍微排版並上註解
Sub test()
TT = Timer
Dim sh0 As Worksheet
Set sh0 = Sheets("輸入")
  ReDim ar(1 To Sheets.Count - 1): w = 1         '主陣列 1維+2維多欄 之後混加10張表 總資料
   ReDim ar0(1 To Sheets.Count - 1)              '次陣列1 1維+2維1欄 10張表 I3:IN3 之後比對用
    ReDim ar1(1 To Sheets.Count - 1)             '次陣列2 1維+2維1欄 10張表 之後混加各表得分加總
     sh0.[i5:T1048576].ClearContents
   
For Each Z In Sheets
If Z.Name <> "輸入" Then
  ar(w) = Z.Range("I5:IN" & Z.Cells(Rows.Count, 2).End(3).Row) '主陣列 混加2維不規則陣列
   ar0(w) = sh0.[I3:IN3]
    ReDim ir(1 To UBound(ar(w)), 0)
     ar1(w) = ir
      If MaxR < UBound(ar(w)) Then MaxR = UBound(ar(w))
       w = w + 1
End If
Next

ReDim ar2(1 To MaxR, 0)                         '次陣列3 2維1欄 加總10張表總得分
  For i = 1 To MaxR: ar2(i, 0) = 0: Next

For i = 1 To UBound(ar)                         '根據主陣列與次陣列1比對算分 記錄在次陣列2
    For j = 1 To UBound(ar(i))                                      '10表總分紀錄在次陣列3
        For k = 1 To 240
         If ar0(i)(1, k) <> "" Then
          If ar(i)(j, k) = ar0(i)(1, k) Then
           ar1(i)(j, 0) = ar1(i)(j, 0) + 1
            ar2(j, 0) = ar2(j, 0) + 1
          End If
         End If
        Next
    Next
Next

For i = 1 To UBound(ar)                          '各表總分依序放入[I5:R1048576]
sh0.Cells(5, i + 8).Resize(UBound(ar1(i)), 1) = ar1(i)
Next
  sh0.[s5].Resize(UBound(ar2), 1) = ar2           '全部總分放入[S5:S1048576]

Set d = CreateObject("scripting.dictionary"): d.RemoveAll        '去重
  For i = 1 To UBound(ar2): d(ar2(i, 0)) = "": Next: d0 = d.keys()

For i = 0 To d.Count - 1                                         '氣泡排序
  For j = i + 1 To d.Count - 1
    If d0(i) < d0(j) Then tp = d0(i): d0(i) = d0(j): d0(j) = tp
  Next
Next
  
ReDim d1(0 To d0(0))                                          '得分轉排名
For i = 0 To UBound(d0): d1(d0(i)) = i + 1: Next
  For i = 1 To UBound(ar2): ar2(i, 0) = d1(ar2(i, 0)): Next
   sh0.[T5].Resize(UBound(ar2), 1) = ar2                      '全部排名放入[T5:T1048576]

sh0.[A1] = Format(Timer - TT, "0.0")
End Sub

singo1232001

回復 22# singo1232001


沒想到加了一個判斷
速度慢了4倍 變成120秒
速度已修正回 40萬筆 38秒
1萬筆1秒
2萬筆2秒
6萬筆6秒
12萬筆11秒
40萬筆38秒
剩下要靠記憶體大小 記憶體速度 跟cpu
不過會因為你資料的多樣性 而影響後續排名的速度
依範例來說只有6個名次 以後可能有600~60000萬個排名時 就會指數級變慢
目前我採用線性方式排名 越大量的排名 速度不會突然變慢很多 是線性成長

Sub test()
TT = Timer  '<可註解移除

Set sh0 = Sheets("輸入")
  ReDim ar(1 To Sheets.Count - 1): w = 1    '主陣列  1維+2維多欄 之後混加10張表 總資料
   ar0 = sh0.[I3:IN3]                       '次陣列1 2維1欄 輸入.[I3:IN3] 之後比對用
    ReDim ar1(1 To Sheets.Count - 1)        '次陣列2 1維+2維1欄 10張表 之後混加各表得分加總
     sh0.[i5:T1048576].ClearContents

For Each Z In Sheets
If Z.Name <> "輸入" Then
  ar(w) = Z.Range("I5:IN" & Z.Cells(Rows.Count, 2).End(3).Row) '主陣列 混加2維不規則陣列
   ReDim ir(1 To UBound(ar(w)), 0)
    ar1(w) = ir
     If MaxR < UBound(ar(w)) Then MaxR = UBound(ar(w))
      w = w + 1
End If
Next

ReDim ar2(1 To MaxR, 0)                    '次陣列3 2維1欄 加總10張表總得分
  For i = 1 To MaxR: ar2(i, 0) = 0: Next

For i = 1 To UBound(ar)                 '根據主陣列與次陣列1比對算分 記錄在次陣列2
    For j = 1 To 240                                        '10表總分紀錄在次陣列3
      If ar0(1, j) <> "" Then '為空不算
         For k = 1 To UBound(ar(i))
          If ar(i)(k, j) = ar0(1, j) Then '輸入與資料判斷相同
           ar1(i)(k, 0) = ar1(i)(k, 0) + 1 '各表 該列+1分
            ar2(k, 0) = ar2(k, 0) + 1      '總表 該列+1分
          End If
         Next
       End If
    Next
Next

For i = 1 To UBound(ar)                          '各表總分依序放入[I5:R1048576]
sh0.Cells(5, i + 8).Resize(UBound(ar1(i)), 1) = ar1(i)
Next
  sh0.[s5].Resize(UBound(ar2), 1) = ar2          '全部總分放入[S5:S1048576]

Set d = CreateObject("scripting.dictionary"): d.RemoveAll        '去重
  For i = 1 To UBound(ar2): d(ar2(i, 0)) = "": Next: d0 = d.keys()

For i = 0 To d.Count - 1                                         '氣泡排序
  For j = i + 1 To d.Count - 1
    If d0(i) < d0(j) Then tp = d0(i): d0(i) = d0(j): d0(j) = tp
  Next
Next

ReDim d1(0 To d0(0))                                         '得分轉排名
  For i = 0 To UBound(d0): d1(d0(i)) = i + 1: Next           '創d1排名對照表陣列
   For i = 1 To UBound(ar2): ar2(i, 0) = d1(ar2(i, 0)): Next '依對照表index修改
    sh0.[T5].Resize(UBound(ar2), 1) = ar2                 '全部排名放入[T5:T1048576]

sh0.[A1] = Format(Timer - TT, "0.0")  '<可註解移除
End Sub

oak0723-1

回復 23# singo1232001


   
除了這1點期於正確
輸入值是0,比對值空白,出現1(如圖1)

oak0723-1

回復 21# samwang

你好
除了下面這一點
其餘正確
輸入值0比對值也是0,比對結果應該為1(如圖(1))

singo1232001

Sub test()
TT = Timer  '<可註解移除

Set sh0 = Sheets("輸入")
  ReDim ar(1 To Sheets.Count - 1): w = 1    '主陣列  1維+2維多欄 之後混加10張表 總資料
   ar0 = sh0.[I3:IN3]                       '次陣列1 2維1欄 輸入.[I3:IN3] 之後比對用
    ReDim ar1(1 To Sheets.Count - 1)        '次陣列2 1維+2維1欄 10張表 之後混加各表得分加總
     sh0.[i5:T1048576].ClearContents

For Each Z In Sheets
If Z.Name <> "輸入" Then
  ar(w) = Z.Range("I5:IN" & Z.Cells(Rows.Count, 2).End(3).Row) '主陣列 混加2維不規則陣列
   ReDim ir(1 To UBound(ar(w)), 0)
    ar1(w) = ir
     If MaxR < UBound(ar(w)) Then MaxR = UBound(ar(w))
      w = w + 1
End If
Next

ReDim ar2(1 To MaxR, 0)                    '次陣列3 2維1欄 加總10張表總得分
  For i = 1 To MaxR: ar2(i, 0) = 0: Next

For i = 1 To UBound(ar)                 '根據主陣列與次陣列1比對算分 記錄在次陣列2
    For j = 1 To 240                                        '10表總分紀錄在次陣列3
      If ar0(1, j) <> "" Then '為空不算
         For k = 1 To UBound(ar(i))
          If ar(i)(k, j) = ar0(1, j) Then '輸入與資料判斷相同
           ar1(i)(k, 0) = ar1(i)(k, 0) + 1 '各表 該列+1分
            ar2(k, 0) = ar2(k, 0) + 1      '總表 該列+1分
                If ar(i)(k, j) = "" And ar0(1, j) = 0 Then
                ar1(i)(k, 0) = ar1(i)(k, 0) - 1 '遇到0="" 把分數扣回來-1
                ar2(k, 0) = ar2(k, 0) - 1       '遇到0="" 把分數扣回來-1
                End If
          End If
         Next
       End If
    Next
Next

For i = 1 To UBound(ar)                          '各表總分依序放入[I5:R1048576]
sh0.Cells(5, i + 8).Resize(UBound(ar1(i)), 1) = ar1(i)
Next
  sh0.[s5].Resize(UBound(ar2), 1) = ar2          '全部總分放入[S5:S1048576]

Set d = CreateObject("scripting.dictionary"): d.RemoveAll        '去重
  For i = 1 To UBound(ar2): d(ar2(i, 0)) = "": Next: d0 = d.keys()

For i = 0 To d.Count - 1                                         '氣泡排序
  For j = i + 1 To d.Count - 1
    If d0(i) < d0(j) Then tp = d0(i): d0(i) = d0(j): d0(j) = tp
  Next
Next

ReDim d1(0 To d0(0))                                         '得分轉排名
  For i = 0 To UBound(d0): d1(d0(i)) = i + 1: Next           '創d1排名對照表陣列
   For i = 1 To UBound(ar2): ar2(i, 0) = d1(ar2(i, 0)): Next '依對照表index修改
    sh0.[T5].Resize(UBound(ar2), 1) = ar2                 '全部排名放入[T5:T1048576]

sh0.[A1] = Format(Timer - TT, "0.0")  '<可註解移除
End Sub

oak0723-1

回復 26# singo1232001


    感謝先進
已與我的希望完全相符

singo1232001

回復 27# oak0723-1

若你還要再快
這裡還有一個再快8%~15%的
缺點是 各表得分不會算 也不會顯示
只會算全部表得分跟排名 會顯示  
若你的記憶體速度2400 Mhz(工作管理員>效能>內可以看記憶體速度)
14萬筆大概13秒    若舊版有顯示的大概14秒   新版的快8~15%   (當然記憶體快會更快)

若你的記憶體速度3200Mhz 我用另一台3200電腦測  
14萬筆大概8.5秒  舊版的9秒

推估記憶體3600Mhz大概可以到7秒 這樣
大概抓1萬筆0.6秒   (當然還是要看資料的複雜程度提升 會花更多時間)


   Sub testFast()
TT = Timer  '<可註解移除

Set sh0 = Sheets("輸入")
  ReDim ar(1 To Sheets.Count - 1): w = 1      '主陣列  1維+2維多欄 之後混加10張表 總資料
   ar0 = sh0.[I3:IN3]                       '次陣列0 2維1欄 輸入.[I3:IN3] 之後比對用
    'ReDim ar1(1 To Sheets.Count - 1)        '次陣列1 1維+2維1欄 10張表 之後混加各表得分加總
     sh0.[i5:T1048576].ClearContents

For Each Z In Sheets
If Z.Name <> "輸入" Then
  ar(w) = Z.Range("I5:IN" & Z.Cells(Rows.Count, 2).End(3).Row) '主陣列 混加2維不規則陣列
'   ReDim ir(1 To UBound(ar(w)), 0)
'    ar1(w) = ir
     If MaxR < UBound(ar(w)) Then MaxR = UBound(ar(w))
      w = w + 1
End If
Next

ReDim ar2(1 To MaxR, 0) As Integer                   '次陣列2 2維1欄 加總10張表總得分
  'For i = 1 To MaxR: ar2(i, 0) = 0: Next

For i = 1 To UBound(ar)                 '根據主陣列與次陣列1比對算分 記錄在次陣列2
    For j = 1 To 240                                        '10表總分紀錄在次陣列3
      If ar0(1, j) <> "" Then '為空不算
         For k = 1 To UBound(ar(i))
          If ar(i)(k, j) = ar0(1, j) Then '輸入與資料判斷相同
          ' ar1(i)(k, 0) = ar1(i)(k, 0) + 1 '各表 該列+1分
            ar2(k, 0) = ar2(k, 0) + 1      '總表 該列+1分
                If ar(i)(k, j) = "" Then
                If ar0(1, j) = 0 Then
                'ar1(i)(k, 0) = ar1(i)(k, 0) - 1 ' '遇到0="" 把分數扣回來-1
                ar2(k, 0) = ar2(k, 0) - 1         '遇到0="" 把分數扣回來-1
                End If
                End If
          End If
         Next
       End If
    Next
Next

'For i = 1 To UBound(ar)                          '各表總分依序放入[I5:R1048576]
'sh0.Cells(5, i + 8).Resize(UBound(ar1(i)), 1) = ar1(i)
'Next
  sh0.[s5].Resize(UBound(ar2), 1) = ar2          '全部總分放入[S5:S1048576]

Set d = CreateObject("scripting.dictionary"): d.RemoveAll        '去重
  For i = 1 To UBound(ar2): d(ar2(i, 0)) = "": Next
    d0 = d.keys()                                                                       '次陣列3

For i = 0 To d.Count - 1                                         '次陣列3 氣泡排序
  For j = i + 1 To d.Count - 1
    If d0(i) < d0(j) Then tp = d0(i): d0(i) = d0(j): d0(j) = tp
  Next
Next

ReDim d1(0 To d0(0))                                         '得分轉排名
  For i = 0 To UBound(d0): d1(d0(i)) = i + 1: Next           '創d1排名對照表陣列
   For i = 1 To UBound(ar2): ar2(i, 0) = d1(ar2(i, 0)): Next '依對照表index修改次陣列3
    sh0.[T5].Resize(UBound(ar2), 1) = ar2                 '全部排名放入[T5:T1048576]

sh0.[A1] = Format(Timer - TT, "0.0")  '<可註解移除
End Sub

oak0723-1

回復 28# singo1232001


    了解
謝謝你