- 帖子
- 2834
- 主題
- 10
- 精華
- 0
- 積分
- 2890
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-11-21
|
5#
發表於 2015-9-10 12:41
| 只看該作者
回復 1# adam2010
１．錄製碼本來執行就慢，尤其含有太多的 Select，須整理為更有效的方式，
不同需求的程式，應分別以 sub 建立單獨程序，要引用時 call 一下即可，
像 Sheets("WIP") 部份，實可獨立成單一程序！
但因不了解處理需求流程，且部份語法在office 2000無法使用，所以無法幫忙整理！
２．僅針對〔交期〕工作表提供個人不正規的寫法，可單獨測試其執行速度，
另執行結果與原檔程式的結果有部份不相同（Ｌ欄標示紅字者），請檢查一下！
３．另提供相同資料配底色程式，視覺上較易分辨各編號的起迄區塊！- Sub 交期()
- Dim R&, C&, Arr, Brr, DateRow, xD, i&, j&, SS&, S&, T$, M
- R = [出貨日!A65535].End(xlUp).Row - 1
- C = [出貨日!IV1].End(xlToLeft).Column - 1
- Arr = [出貨日!A1].Resize(R, C)
- ReDim Brr(1 To C - 1)
- Set xD = CreateObject("Scripting.Dictionary")
- For j = 2 To C: Brr(C - j + 1) = Arr(1, j): Next j: DateRow = Brr '日期由大而小倒轉
-
- For i = 2 To R
- For j = 2 To C '數量累計〔由後而前〕排入陣列
- S = Val(Arr(i, j)): SS = SS + S
- If S = 0 Then Brr(C - j + 1) = "" Else Brr(C - j + 1) = SS
- Next j
- If SS > 0 Then xD(Arr(i, 1)) = Brr: SS = 0 '將累計數列納入字典檔
- 101: Next i
- '======================================================
- R = [交期!A65535].End(xlUp).Row
- Arr = [交期!A1].Resize(R, 4)
- ReDim Brr(1 To R, 0): Brr(1, 0) = "交期"
- For i = 2 To R
- T = Arr(i, 1): S = Arr(i, 4)
- If T <> Arr(i - 1, 1) Then SS = S Else SS = SS + S 'Ａ欄相同，累計，反之，取當前數量
- M = Application.Match(SS, xD(T), -1) '利用MATCH〔反序〕找相對位置
- If S = 0 Or IsError(M) Then Brr(i, 0) = "NA" Else Brr(i, 0) = DateRow(M) '無符合填NA，否則填日期
- Next i
- [交期!E1].Resize(R) = Brr
- End Sub
 ESOD_XT_AA_v001.rar (425.39 KB)
|
|
發表於 2015-9-9 23:49
| 
