麻辣家族討論版版 - Powered by Discuz! Board

標題: 大量資料比對計算及排名 [打印本頁]

作者: oak0723-1 時間: 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))))

作者: samwang 時間: 2022-5-14 08:18

回復 1# oak0723-1

圖1與圖2都是一樣

作者: oak0723-1 時間: 2022-5-14 10:44

回復 2# samwang

抱歉抱歉
忘了檢查

作者: samwang 時間: 2022-5-15 09:43

回復 3# oak0723-1 [/b

你的圖2與附檔有點不一樣，且附檔的公式也跑掉了，
對不起很認真的在看了，但還是看不需求，可以另外描敘一下，感謝
作者: oak0723-1 時間: 2022-5-15 18:57

回復 4# samwang

抱歉抱歉
一錯再錯

更新資料

(1).(如圖001)在工作表"比對"的I3~IN3儲存格輸入資料
(2).(如圖002)工作表"01"的I3~IN3儲存格資料=工作表"輸入"I3~IN3儲存格資料
(3).(如圖002)工作表"01"I3:IN1048528的每一列儲存格資料都與I3~IN3儲存格資料比對,相同=1,不相同=0.空白=不進行比對,將比對結果逐列顯示於IT5:RY1048528儲存格
(4).(如圖002)與工作表"01"相同的工作表有10個,期內容格式相同,但I3:IN1048528的儲存格資料不同
(5).(如圖001)將每個工作表("01"~"10")的IT5:RY1048528儲存格之每一列合計顯示於工作表"輸入"的I5~R1048528
(6).(如圖001).將工作表"輸入"的I5~R1048528逐列合計
(7).(如圖001)將工作表"輸入"的I5~R1048528逐列排名(例如 T5=SUMPRODUCT(($S$5:$S$14>=S5)*(1/COUNTIF(S$5:S$14,S$5:S$14))))
[attach]34875[/attach][attach]34875[/attach][attach]34875[/attach]
作者: samwang 時間: 2022-5-16 14:16

回復 5# oak0723-1

因為你的描述中第1點~7點有包含說明和需求，所以不確定如下是否為您的需求，如圖片紅框是有處理的結果，請測試看看，謝謝。

Sub test()
Dim Ar_in, Arr, Arr1, Brr(), Crr(), xD, T, T1, n&, i&, j&, R&
Set xD = CreateObject("Scripting.Dictionary")
Ar_in = Sheets("輸入").Range("i3:in3")
For sh = 2 To Sheets.Count
With Sheets(sh)
      .Range("i3").Resize(1, UBound(Ar_in, 2)) = Ar_in
      R = .[b65536].End(3).Row: If R < 2 Then GoTo 95
      Arr1 = .Range(.[b5], .[b65536].End(3)): Arr = .Range("i3:in" & UBound(Arr1) + 4)
      ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2))    'IT3:RY
      ReDim Preserve Crr(1 To UBound(Arr) - 1, 1 To sh - 1)  '輸入的統計
      Crr(1, sh - 1) = .Name
      For x = 1 To UBound(Arr1)
         If Arr1(x, 1) = "" Then GoTo 95
         For i = 3 To UBound(Arr)
            For j = 1 To UBound(Arr, 2)
                  T = Arr(i, j): T1 = Arr(1, j)
                  If T1 = "" Then GoTo 90
                  If T1 = T Then
                     Brr(i - 2, j) = 1: n = n + 1
                  Else
                     Brr(i - 2, j) = 0
                  End If
90:          Next j
         Crr(i - 1, sh - 1) = n: n = 0
         Next i
95:    Next x
      .[it5].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End With
Next
n = 0
With Sheets(1)
.[i4:r4].NumberFormatLocal = "@"
.[i4].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
With [s5].Resize(UBound(Crr) - 1)
         .Formula = "=Sum(i5:r5)": .Value = .Value
End With
With Range([s5], [s4].End(4))
      Arr = .Value
      .Sort Key1:=.Item(1), Order1:=2, Header:=2
      Brr = .Value: .Value = Arr
End With
For i = 1 To UBound(Brr)
      T = Brr(i, 1): If Not xD.Exists(T) Then n = n + 1: xD(T) = n
Next
For i = 1 To UBound(Arr): Arr(i, 1) = xD(Arr(i, 1)): Next
.[t5].Resize(UBound(Arr)) = Arr
End With
End Sub
作者: oak0723-1 時間: 2022-5-16 16:43

回復 6# samwang

先進你好
我執行後卡住如圖
我這個檔的概念就是想計算1組數字跟工作表01-10的每1列數據比較
計算每列相同數據的數量有多少
作者: samwang 時間: 2022-5-16 17:47

回復 7# oak0723-1

已更新如下，請再測試看看，謝謝
另外"輸入"工作表要放在第1個

Sub test()
Dim Ar_in, Arr, Arr1, Brr(), Crr(), xD, T, T1, n&, i&, j&, R&, sh%, MaxR&
Set xD = CreateObject("Scripting.Dictionary")
Ar_in = Sheets("輸入").Range("i3:in3")
For sh = 2 To Sheets.Count
With Sheets(sh)
      .Range("i3").Resize(1, UBound(Ar_in, 2)) = Ar_in
      R = .[b65536].End(3).Row: If R < 2 Then GoTo 95
      Arr1 = .Range(.[b5], .[b65536].End(3)): Arr = .Range("i3:in" & UBound(Arr1) + 4)
      ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2)) 'IT3:RY
      ReDim Preserve Crr(1 To 100000, 1 To sh - 1)    '輸入的統計
      If MaxR < UBound(Arr) Then MaxR = UBound(Arr)
      Crr(1, sh - 1) = .Name
      For x = 1 To UBound(Arr1)
         If Arr1(x, 1) = "" Then GoTo 95
         For i = 3 To UBound(Arr)
            For j = 1 To UBound(Arr, 2)
                  T = Arr(i, j): T1 = Arr(1, j)
                  If T1 = "" Then GoTo 90
                  If T1 = T Then
                     Brr(i - 2, j) = 1: n = n + 1
                  Else
                     Brr(i - 2, j) = 0
                  End If
90:          Next j
         Crr(i - 1, sh - 1) = n: n = 0
         Next i
95:    Next x
      .[it5].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End With
Next
n = 0
With Sheets(1)
.[i4:r4].NumberFormatLocal = "@"
.[i4].Resize(MaxR, UBound(Crr, 2)) = Crr
With .[s5].Resize(MaxR - 2)
         .Formula = "=Sum(i5:r5)": .Value = .Value
End With
With Range([s5], [s4].End(4))
      Arr = .Value
      .Sort Key1:=.Item(1), Order1:=2, Header:=2
      Brr = .Value: .Value = Arr
End With
For i = 1 To UBound(Brr)
      T = Brr(i, 1): If Not xD.Exists(T) Then n = n + 1: xD(T) = n
Next
For i = 1 To UBound(Arr): Arr(i, 1) = xD(Arr(i, 1)): Next
.[t5].Resize(UBound(Arr)) = Arr
End With
End Sub
作者: oak0723-1 時間: 2022-5-16 19:49

回復 8# samwang

我將工作表09的!5~IN1048528區域資料全部刪除執行程式後再輸入A1資料
結果就卡住了(如圖)
作者: samwang 時間: 2022-5-16 21:03

回復  samwang

我將工作表09的!5~IN1048528區域資料全部刪除執行程式後再輸入A1資料
結果就卡住 ...
oak0723-1 發表於 2022-5-16 19:49

已更新如附件，請測試看看，謝謝
作者: oak0723-1 時間: 2022-5-17 09:12

本帖最後由 oak0723-1 於 2022-5-17 09:16 編輯

回復 10# samwang

先進你好
我將工作表01的I5:I1005填入資料1萬列資料,執行沒多久就顯示"沒回應",我想應該是當了
後來我一直刪減工作表01的I5:I1005資料列數測試執行,發現剩2千列耗約15分鍾完成
不知是否執行速度效能是否有辦法予以提升?
作者: samwang 時間: 2022-5-17 11:02

本帖最後由 samwang 於 2022-5-17 11:15 編輯

回復  samwang

先進你好
我將工作表01的I5:I1005填入資料1萬列資料,執行沒多久就顯示"沒回應",我 ...
oak0723-1 發表於 2022-5-17 09:12

已更新，4萬多筆約12秒，檔案太大66M不上傳，請自行建資料後再測試看看，謝謝
另外，用你的#11附件檔案去執行會跑很久(當掉)，重建資料數據，建議數值轉為值不要框線然後再執行程式(如圖片)

Sub test()
Dim Ar_in, Arr, Arr1, Brr(), Crr(), xD, T, T1, n&, i&, j&, R&, sh%, MaxR&
Set xD = CreateObject("Scripting.Dictionary")
Tm = Timer
Ar_in = Sheets("輸入").Range("i3:in3")
For sh = 2 To Sheets.Count
With Sheets(sh)
      .Range("i3").Resize(1, UBound(Ar_in, 2)) = Ar_in
      R = .[b65536].End(3).Row: If R < 2 Then GoTo 95
      Arr1 = .Range("b4:b" & R): Arr = .Range("i3:in" & R)
      ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2)) 'IT3:RY
      ReDim Preserve Crr(1 To 100000, 1 To sh - 1)    '輸入的統計
      If MaxR < UBound(Arr) Then MaxR = UBound(Arr)
      Crr(1, sh - 1) = .Name
      For i = 3 To UBound(Arr)
         For j = 1 To UBound(Arr, 2)
            T = Arr(i, j): T1 = Arr(1, j)
            If T1 = "" Then GoTo 90
            If T1 = T Then
                  Brr(i - 2, j) = 1: n = n + 1
            Else
                  Brr(i - 2, j) = 0
            End If
90:       Next j
         Crr(i - 1, sh - 1) = n: n = 0
95: Next i
      .[it5].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End With
Next
n = 0
With Sheets(1)
.[i4:r4].NumberFormatLocal = "@"
.[i4].Resize(MaxR, UBound(Crr, 2)) = Crr
With .[s5].Resize(MaxR - 2)
         .Formula = "=Sum(i5:r5)": .Value = .Value
End With
With Range([s5], [s4].End(4))
      Arr = .Value
      .Sort Key1:=.Item(1), Order1:=2, Header:=2
      Brr = .Value: .Value = Arr
End With
For i = 1 To UBound(Brr)
      T = Brr(i, 1): If Not xD.Exists(T) Then n = n + 1: xD(T) = n
Next
For i = 1 To UBound(Arr): Arr(i, 1) = xD(Arr(i, 1)): Next
.[t5].Resize(UBound(Arr)) = Arr
End With
MsgBox Timer - Tm
End Sub
[attach]34905[/attach]
作者: oak0723-1 時間: 2022-5-17 19:49

回復 12# samwang

謝謝
完全符合我的希望
謝謝你
作者: singo1232001 時間: 2022-5-21 06:20

本帖最後由 singo1232001 於 2022-5-21 06:35 編輯

回復 13# oak0723-1

excel 2019
2017年的電腦  r7-1700x  記憶體3000 cpu99%

10頁共40萬筆 36秒

檔案大小 336MB
https://drive.google.com/file/d/1dRNroDrAKxhnoKg9qp9IJhO7pemwGh6j/view?usp=sharing

多的部分都刪了  IN 右邊的都刪了  太龐大

要大量資料就要盡量不用任何顏色格式
作者: oak0723-1 時間: 2022-5-21 07:33

回復 14# singo1232001

收到
感恩
:)
作者: oak0723-1 時間: 2022-5-21 08:48

本帖最後由 oak0723-1 於 2022-5-21 08:54 編輯

回復 14# singo1232001

  抱歉
我剛測試發現幾個問題

就是當在工作表"輸入" L3儲存格輸入4001(如圖01)
而工作表01-10的儲存格L3卻沒有跟著改變(圖02)
所以比對結果也有問題(如圖03)
工作表01-10沒有比對結結果(如圖04)
作者: singo1232001 時間: 2022-5-21 15:40

本帖最後由 singo1232001 於 2022-5-21 15:52 編輯

回復 16# oak0723-1

改好了會在程序裡更新
不過表上不變更  若想要用=號更新01~10[I3~IN3] 檔案會變慢
目前01~10[I3:IN3]甚至刪掉也可以

Sub test()
TT = Timer
Set sh0 = Sheets("輸入")
ReDim ar(1 To Sheets.Count - 1): w = 1
ReDim ar0(1 To Sheets.Count - 1)
ReDim ar1(1 To Sheets.Count - 1)
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)
  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)
For i = 1 To MaxR: ar2(i, 0) = 0: Next

For i = 1 To UBound(ar)
For j = 1 To UBound(ar(i))
      For k = 1 To 240
      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
      Next
Next
Next

For i = 1 To UBound(ar)
sh0.Cells(5, i + 8).Resize(UBound(ar1(i)), 1) = ar1(i)
Next
sh0.[s5].Resize(UBound(ar2), 1) = ar2

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 j:  Next i
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

sh0.[A1] = Format(Timer - TT, "0.0")
End Sub
作者: oak0723-1 時間: 2022-5-21 16:56

回復 17# singo1232001

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

回復 12# samwang

抱歉,漏了1個問題
1.輸入欄位若是空白,就不比對,所得的值就是0(如圖)
2.輸入欄位若是0,比對蘭欄位若是空白,所得的值也是0(如圖)
作者: singo1232001 時間: 2022-5-21 17:26

本帖最後由 singo1232001 於 2022-5-21 17:27 編輯

回復 19# oak0723-1

測試看看

Sub test()
TT = Timer
Set sh0 = Sheets("輸入")
ReDim ar(1 To Sheets.Count - 1): w = 1
ReDim ar0(1 To Sheets.Count - 1)
ReDim ar1(1 To Sheets.Count - 1)
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)
  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)
For i = 1 To MaxR: ar2(i, 0) = 0: Next

For i = 1 To UBound(ar)
For j = 1 To UBound(ar(i))
      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)
sh0.Cells(5, i + 8).Resize(UBound(ar1(i)), 1) = ar1(i)
Next
sh0.[s5].Resize(UBound(ar2), 1) = ar2

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 j:  Next i
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

sh0.[A1] = Format(Timer - TT, "0.0")
End Sub
作者: samwang 時間: 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
作者: singo1232001 時間: 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
作者: singo1232001 時間: 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
作者: oak0723-1 時間: 2022-5-22 22:27

回復 23# singo1232001

除了這1點期於正確
輸入值是0,比對值空白,出現1(如圖1)
作者: oak0723-1 時間: 2022-5-22 22:30

回復 21# samwang

你好
除了下面這一點
其餘正確
輸入值0比對值也是0,比對結果應該為1(如圖(1))
作者: singo1232001 時間: 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
作者: oak0723-1 時間: 2022-5-23 06:00

回復 26# singo1232001

感謝先進
已與我的希望完全相符
作者: singo1232001 時間: 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
作者: oak0723-1 時間: 2022-5-24 06:39

回復 28# singo1232001

了解
謝謝你

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