大量資料比對計算及排名
各位先進好我有一個資料如附件(因上傳檔案大小限制,故刪除部份工作表及儲存格)
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)))) [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118800&ptid=23662]1#[/url] [i]oak0723-1[/i] [/b]
圖1與圖2都是一樣 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118802&ptid=23662]2#[/url] [i]samwang[/i] [/b]
抱歉抱歉
忘了檢查 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118803&ptid=23662]3#[/url] [i]oak0723-1[/i] [/b
你的圖2與附檔有點不一樣，且附檔的公式也跑掉了，
對不起很認真的在看了，但還是看不需求， 可以另外描敘一下，感謝 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118806&ptid=23662]4#[/url] [i]samwang[/i] [/b]
抱歉抱歉
一錯再錯
更新資料
(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] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118809&ptid=23662]5#[/url] [i]oak0723-1[/i] [/b]
因為你的描述中第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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118810&ptid=23662]6#[/url] [i]samwang[/i] [/b]
先進你好
我執行後卡住如圖
我這個檔的概念就是想計算1組數字跟工作表01-10的每1列數據比較
計算每列相同數據的數量有多少 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118811&ptid=23662]7#[/url] [i]oak0723-1[/i] [/b]
已更新如下，請再測試看看，謝謝
另外[color=Red]"輸入"工作表[/color]要放在[color=Red]第1個[/color]
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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118812&ptid=23662]8#[/url] [i]samwang[/i] [/b]
我將工作表09的!5~IN1048528區域資料全部刪除執行程式後再輸入A1資料
結果就卡住了(如圖) [quote]回復 samwang
我將工作表09的!5~IN1048528區域資料全部刪除執行程式後再輸入A1資料
結果就卡住 ...
[size=2][color=#999999]oak0723-1 發表於 2022-5-16 19:49[/color] [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118813&ptid=23662][img]http://forum.twbts.com/images/common/back.gif[/img][/url][/size][/quote]
已更新如附件，請測試看看，謝謝 [i=s] 本帖最後由 oak0723-1 於 2022-5-17 09:16 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118814&ptid=23662]10#[/url] [i]samwang[/i] [/b]
先進你好
我將工作表01的I5:I1005填入資料1萬列資料,執行沒多久就顯示"沒回應",我想應該是當了
後來我一直刪減工作表01的I5:I1005資料列數測試執行,發現剩2千列耗約15分鍾完成
不知是否執行速度效能是否有辦法予以提升? [i=s] 本帖最後由 samwang 於 2022-5-17 11:15 編輯 [/i]
[quote]回復 samwang
先進你好
我將工作表01的I5:I1005填入資料1萬列資料,執行沒多久就顯示"沒回應",我 ...
[size=2][color=#999999]oak0723-1 發表於 2022-5-17 09:12[/color] [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118815&ptid=23662][img]http://forum.twbts.com/images/common/back.gif[/img][/url][/size][/quote]
已更新，4萬多筆約12秒，檔案太大66M不上傳，請自行建資料後再測試看看，謝謝
[color=Blue]另外，用你的#11附件檔案去執行會跑很久(當掉)，重建資料數據，建議數值轉為值不要框線然後再執行程式(如圖片)[/color]
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] [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118816&ptid=23662]12#[/url] [i]samwang[/i] [/b]
謝謝
完全符合我的希望
謝謝你 [i=s] 本帖最後由 singo1232001 於 2022-5-21 06:35 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118817&ptid=23662]13#[/url] [i]oak0723-1[/i] [/b]
excel 2019
2017年的電腦 r7-1700x 記憶體3000 cpu99%
10頁 共40萬筆 36秒
檔案大小 336MB
https://drive.google.com/file/d/1dRNroDrAKxhnoKg9qp9IJhO7pemwGh6j/view?usp=sharing
多的部分都刪了 IN 右邊的都刪了 太龐大
要大量資料 就要盡量不用任何顏色格式 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118838&ptid=23662]14#[/url] [i]singo1232001[/i] [/b]
收到
感恩
:) [i=s] 本帖最後由 oak0723-1 於 2022-5-21 08:54 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118838&ptid=23662]14#[/url] [i]singo1232001[/i] [/b]
抱歉
我剛測試發現幾個問題
就是當在工作表"輸入" L3儲存格輸入4001(如圖01)
而工作表01-10的儲存格L3卻沒有跟著改變(圖02)
所以比對結果也有問題(如圖03)
工作表01-10沒有比對結結果(如圖04) [i=s] 本帖最後由 singo1232001 於 2022-5-21 15:52 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118840&ptid=23662]16#[/url] [i]oak0723-1[/i] [/b]
改好了 會在程序裡更新
不過表上不變更 若想要用=號更新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 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118845&ptid=23662]17#[/url] [i]singo1232001[/i] [/b]
抱歉,漏了1個問題
1.輸入欄位若是空白,就不比對,所得的值就是0(如圖)
2.輸入欄位若是0,比對蘭欄位若是空白,所得的值也是0(如圖) [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118816&ptid=23662]12#[/url] [i]samwang[/i] [/b]
抱歉,漏了1個問題
1.輸入欄位若是空白,就不比對,所得的值就是0(如圖)
2.輸入欄位若是0,比對蘭欄位若是空白,所得的值也是0(如圖) [i=s] 本帖最後由 singo1232001 於 2022-5-21 17:27 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=118847&ptid=23662]19#[/url] [i]oak0723-1[/i] [/b]
測試看看
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
頁:
[1]
2