123
返回列表 上一主題 發帖

大量資料比對計算及排名

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
1# 跳轉到 » 正序看帖
打印
tT
發表於 2022-5-13 23:01 | 只看該作者

大量資料比對計算及排名

各位先進好
我有一個資料如附件(因上傳檔案大小限制,故刪除部份工作表及儲存格)
1.(如圖01)在工作表"比對"的I3~IN3儲存格輸入資料
2..(如圖02)工作表"01"的I3~IN3儲存格資料=工作表"輸入"I3~IN3儲存格資料
3..(如圖02)工作表"01"I3:IN1048528的每一列儲存格資料都與I3~IN3儲存格資料比對,相同=1,不相同=0.空白=不進行比對,將比對結果逐列顯示於IT5:RY1048528儲存格
4..(如圖02)與工作表"01"相同的工作表有10個,除I3:IN1048528的儲存格內資料不一樣(列數欄數都不一樣),其他都一樣
5..(如圖01)將每個工作表("01"~"10")的IT5:RY1048528儲存格之每一列合計顯示於工作表"輸入"的I5~R1048528(若整列空白則不作計算)
6.(如圖01).將工作表"輸入"的I5~R1048528非空白逐列合計
7..(如圖01)將工作表"輸入"的I5~R1048528非空白逐列排名(例如S5=SUMPRODUCT(($S$5:$S$14>=S5)*(1/COUNTIF(S$5:S$14,S$5:S$14))))

圖01.jpg (239.16 KB)

圖01.jpg

圖02.jpg (238.51 KB)

圖02.jpg

(1110513)比對.rar (37.42 KB)

收藏 分享

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
29#
發表於 2022-5-24 06:39 | 只看該作者
回復 28# singo1232001


    了解
謝謝你

TOP

singo1232001
　暱稱: 熱狗慶

中學生Rank: 2

帖子
354 
主題
5 
精華
0 
積分
387 
點名
0  
作業系統
windows7 
軟體版本
vba,vb,excel2007 
閱讀權限
20 
性別
男 
註冊時間
2017-1-8 
最後登錄
2024-8-2 

論壇榮譽勳章論壇贊助勳章
28#
發表於 2022-5-24 03:54 | 只看該作者
本帖最後由 singo1232001 於 2022-5-24 04:09 編輯

回復 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

TOP

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
27#
發表於 2022-5-23 06:00 | 只看該作者
回復 26# singo1232001


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

TOP

singo1232001
　暱稱: 熱狗慶

中學生Rank: 2

帖子
354 
主題
5 
精華
0 
積分
387 
點名
0  
作業系統
windows7 
軟體版本
vba,vb,excel2007 
閱讀權限
20 
性別
男 
註冊時間
2017-1-8 
最後登錄
2024-8-2 

論壇榮譽勳章論壇贊助勳章
26#
發表於 2022-5-22 23:22 | 只看該作者
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

TOP

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
25#
發表於 2022-5-22 22:30 | 只看該作者
回復 21# samwang

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

圖(1).jpg (238.74 KB)

圖(1).jpg

TOP

oak0723-1

帖子
222 
主題
56 
精華
0 
積分
285 
點名
0  
作業系統
window 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2010-8-30 
最後登錄
2024-4-22 

論壇贊助勳章論壇榮譽勳章
24#
發表於 2022-5-22 22:27 | 只看該作者
回復 23# singo1232001


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

圖-1.jpg (272.2 KB)

圖-1.jpg

TOP

singo1232001
　暱稱: 熱狗慶

中學生Rank: 2

帖子
354 
主題
5 
精華
0 
積分
387 
點名
0  
作業系統
windows7 
軟體版本
vba,vb,excel2007 
閱讀權限
20 
性別
男 
註冊時間
2017-1-8 
最後登錄
2024-8-2 

論壇榮譽勳章論壇贊助勳章
23#
發表於 2022-5-21 23:15 | 只看該作者
本帖最後由 singo1232001 於 2022-5-21 23:28 編輯

回復 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

TOP

singo1232001
　暱稱: 熱狗慶

中學生Rank: 2

帖子
354 
主題
5 
精華
0 
積分
387 
點名
0  
作業系統
windows7 
軟體版本
vba,vb,excel2007 
閱讀權限
20 
性別
男 
註冊時間
2017-1-8 
最後登錄
2024-8-2 

論壇榮譽勳章論壇贊助勳章
22#
發表於 2022-5-21 22:19 | 只看該作者
本帖最後由 singo1232001 於 2022-5-21 22:30 編輯

'若沒問題的話  這個有稍微排版並上註解
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

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-10-30 
21#
發表於 2022-5-21 18:16 | 只看該作者
回復  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

1.JPG (241.34 KB)

1.JPG

TOP

        靜思自在 : 唯其尊重自己的人，才更勇於縮小自己。
123
返回列表 上一主題