帖子: 145
主題: 42
精華: 0
積分: 193
點名: 0
作業系統: Windows7
軟體版本: Office2010
閱讀權限: 20
性別: 男
註冊時間: 2010-11-25
最後登錄: 2024-10-10

論壇贊助勳章

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2018-4-22 00:50 | 只看該作者

[發問] 巨集執行緩慢改善

請教一下各位前輩高手，小弟做了一段比較訂單的巨集，但是執行上相當緩慢，不知是否有其他寫法可加速
主要是根據達交日/料號/訂單編號/項次來判定是兩天的同一張訂單去比較

因為每日會有入庫所以正常day2應該會比day1少，若是增加則視為異常

因為每次執行此段都會相當緩慢，不知是否有改善的方法，謝謝！

訂單比較-問題.rar (53.27 KB)

樓主熱帖

Adam

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2839
主題: 10
精華: 0
積分: 2895
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-12-27

2^#

發表於 2018-4-22 10:57 | 只看該作者

Sub 比較()
Dim xRow1&, xRow2&, xTT$
[day2!R1] = "昨日": [day2!S1] = "差異"
'↓R欄公式的〔預設公式字串〕
xTT = "=SUMPRODUCT((B2=day1!B$2:B$//)*(day2!E2=day1!E$2:E$//)*(day2!N2=day1!N$2:N$//)*(day2!O2=day1!O$2:O$//),day1!H$2:H$//)"

xRow1 = [day1!A65536].End(xlUp).Row
xRow2 = [day2!A65536].End(xlUp).Row
'↓將〔預設公式字串〕中的〔//〕替換為實際〔day1〕最後一列號，填入Ｒ欄
[day2!R2].Resize(xRow2 - 1) = Replace(xTT, "//", xRow1)
[day2!S2].Resize(xRow2 - 1) = "=IF(H2-R2>0,""增加"","""")"
End Sub

會緩慢是因為公式〔全欄引用〕，資料只有５００筆左右，限定參照範圍即可！
若資料筆數真的很多，可改用字典檔及ARRAY

TOP

iamaraymond

　暱稱: Raymond Chien

中學生 Rank: 2

帖子: 109
主題: 12
精華: 0
積分: 177
點名: 0
作業系統: win10
軟體版本: office2013
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2017-11-19
最後登錄: 2023-7-5

3^#

發表於 2018-4-22 11:53 | 只看該作者

回復 2# 准提部林

版主的程式碼好強，剛剛自己用Array試，但速度還是很慢，應該是自己用錯方法
可以請版主示範一下如何用字典及Array操作嗎?
真心想向版主學習，感謝

Excel VBA網頁資料收集教學:
http://forum.twbts.com/thread-20848-1-1.html

TOP

adam2010

中學生 Rank: 2

帖子: 145
主題: 42
精華: 0
積分: 193
點名: 0
作業系統: Windows7
軟體版本: Office2010
閱讀權限: 20
性別: 男
註冊時間: 2010-11-25
最後登錄: 2024-10-10

論壇贊助勳章

4^#

發表於 2018-4-22 13:20 | 只看該作者

回復 2# 准提部林

感謝版主出手協助，加快很多，資料大多不會超過千筆所以應該這樣就可以了，感謝！

Adam

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2839
主題: 10
精華: 0
積分: 2895
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-12-27

5^#

發表於 2018-4-22 15:56 | 只看該作者

回復 3# iamaraymond

Sub 比較2()
Dim Arr, Brr, xD, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([day1!Q1], [day1!A65536].End(xlUp))
For i = 2 To UBound(Arr)
xD(Arr(i, 2) & Arr(i, 5) & Arr(i, 14) & Arr(i, 15)) = Val(Arr(i, 8))
Next i
Arr = Range([day2!Q1], [day2!A65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 2)
Brr(1, 1) = "昨日": Brr(1, 2) = "差異"
For i = 2 To UBound(Arr)
Brr(i, 1) = Val(xD(Arr(i, 2) & Arr(i, 5) & Arr(i, 14) & Arr(i, 15)))
If Val(Arr(i, 8)) > Brr(i, 1) Then Brr(i, 2) = "增加"
Next i
[day2!R1:S1].Resize(UBound(Arr)) = Brr
End Sub

複製代碼

TOP

adam2010

中學生 Rank: 2

帖子: 145
主題: 42
精華: 0
積分: 193
點名: 0
作業系統: Windows7
軟體版本: Office2010
閱讀權限: 20
性別: 男
註冊時間: 2010-11-25
最後登錄: 2024-10-10

論壇贊助勳章

6^#

發表於 2018-4-22 16:31 | 只看該作者

回復 5# 准提部林

果然是高手，更快了，不知准大平時從事什麼工作，怎麼會有如此深厚的功力，太強大了

Adam

TOP

iamaraymond

　暱稱: Raymond Chien

中學生 Rank: 2

帖子: 109
主題: 12
精華: 0
積分: 177
點名: 0
作業系統: win10
軟體版本: office2013
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2017-11-19
最後登錄: 2023-7-5

7^#

發表於 2018-4-22 17:04 | 只看該作者

回復 5# 准提部林

感謝版主，我在研究看看，一直都不太知道如何使用字典@@

Excel VBA網頁資料收集教學:
http://forum.twbts.com/thread-20848-1-1.html

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-12-5

8^#

發表於 2023-5-30 13:23 | 只看該作者

本帖最後由 Andy2483 於 2023-5-30 13:48 編輯

回復 5# 准提部林

謝謝論壇,謝謝前輩
後學藉此帖學習前輩的方案,方案學習心得註解如下,請前輩再指導

執行前:

執行結果:

Sub 比較2()
Dim Arr, Brr, xD, i&
'↑宣告變數
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD變數是字典
Arr = Range([day1!Q1], [day1!A65536].End(xlUp))
'↑令Arr變數是二維陣列,以 "day1"表A~Q欄儲存格值帶入陣列中
For i = 2 To UBound(Arr)
'↑設順迴圈
xD(Arr(i, 2) & Arr(i, 5) & Arr(i, 14) & Arr(i, 15)) = Val(Arr(i, 8))
'↑令第(2,5,14,15)欄陣列值組成的新字串當key,item是 8欄陣列值轉數值
Next i
Arr = Range([day2!Q1], [day2!A65536].End(xlUp))
'↑令Arr陣列換裝 "day2"表A~Q欄儲存格值
ReDim Brr(1 To UBound(Arr), 1 To 2)
'↑宣告Brr變數是二維空陣列,縱向範圍同Arr陣列,橫向範圍1~2
Brr(1, 1) = "昨日": Brr(1, 2) = "差異"
'↑令Brr陣列第1列是標題列
For i = 2 To UBound(Arr)
'↑設順迴圈!
Brr(i, 1) = Val(xD(Arr(i, 2) & Arr(i, 5) & Arr(i, 14) & Arr(i, 15)))
'↑令Brr第1欄迴圈陣列值是以第(2,5,14,15)欄陣列值組成的新字串,查
'查xD字典回傳item值轉數值
If Val(Arr(i, 8)) > Brr(i, 1) Then Brr(i, 2) = "增加"
'↑如果第8欄Arr迴圈陣列值轉數值大於 Brr1欄陣列值,
'就令Brr第2欄陣列值以 "增加"字串寫入
Next i
[day2!R1:S1].Resize(UBound(Arr)) = Brr
'↑令Brr陣列值從 "day2"表[R1]開始寫入儲存格中
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-12-5

9^#

發表於 2023-5-30 14:34 | 只看該作者

謝謝論壇,謝謝各位前輩
後學藉此帖學習以前輩的方案改成一個陣列處理的方案,學習方案如下,請各位前輩指教

Sub TEST()
Dim Brr, Y, i&, Sh1 As Worksheet, Sh2 As Worksheet
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是字典
Set Sh1 = Sheets("day1"): Set Sh2 = Sheets("day2")
'↑令Sh1變數是名為 "day1"的工作表,令Sh2變數是名為 "day2"的工作表
Brr = Range(Sh1.[Q1], Sh1.[A65536].End(3))
'↑令Brr變數是二維陣列,以Sh1工作表A~Q欄儲存格值帶入陣列中
For i = 2 To UBound(Brr)
'↑設順迴圈
Y(Brr(i, 2) & Brr(i, 5) & Brr(i, 14) & Brr(i, 15)) = Val(Brr(i, 8))
'↑令第(2,5,14,15)欄陣列值組成的新字串當key,item是第8欄陣列值轉數值
Next
Brr = Range(Sh2.[Q2], Sh2.[A65536].End(3))
'↑令Brr陣列換裝 Sh1工作表A~Q欄儲存格值(不含標題列)
For i = 1 To UBound(Brr)
'↑設順迴圈
Brr(i, 1) = Val(Y(Brr(i, 2) & Brr(i, 5) & Brr(i, 14) & Brr(i, 15)))
'↑令Brr第1欄迴圈陣列值是以第(2,5,14,15)欄陣列值組成的新字串,查
'查Y字典回傳item值轉數值(以結果值覆蓋原陣列值)
If Val(Brr(i, 8)) > Brr(i, 1) Then Brr(i, 2) = "增加" Else Brr(i, 2) = ""
'↑如果第8欄Brr迴圈陣列值轉數值大於 Brr第1欄陣列值,
'就令Brr第2欄陣列值以 "增加"字串寫入,否則就讓空白
Next
Sh2.[R2].Resize(UBound(Brr), 2) = Brr: Sh2.[R1:S1] = [{"昨日","差異"}]
'↑令Brr陣列值從Sh2表[R2]寫入儲存格中,令[R1:S1]寫入列標題
Set Y = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing: Erase Brr
'↑令釋放變數
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP