准提部林

回復 30# shuo1125

稍改
Xl0000068.rar (29.5 KB)

下載次數: 11

2022-9-24 15:55

shuo1125

回復 31# 准提部林
准大好！
對於字典的key跟item還是不太了解...xD(T1 & "/" & T2) = 0 中，
這一段是調用xD(key)=item，所以當判斷為0時就去重的意思嗎..?
您的邏輯思路真的是太厲害了，
完全符合使用，太感謝了..

准提部林

回復 32# shuo1125


Key值還沒抓進字典前, 它的item是 空字符"" 或 0,
if xd("??")=0  即可判斷還沒納入字典,
但這是偷懶用法, 因為已事先知道下面的程式不會給這個字典寫入 空字符 或 0 值!!!
判斷是否已納入字典, 標準用法如下:
If not xD.Exists("??") Then

shuo1125

回復 33# 准提部林
原來是這樣的判斷方式，
自己在寫時都想不到這些，所以才要再上來問..
您的思路及見解真的太獨到，
感謝准大...還抽空回覆。

Andy2483

回復 34# shuo1125


    前輩們教師節快樂!
每位前輩都有後學可以學習的!都是後學的老師!
謝謝前輩發表此主題與範例!
後學藉題學習,如有冒犯,請見諒!

Andy2483

回復 31# 准提部林


    謝謝前輩指導
後學駑鈍! 學習您的範例真的很難!
註解心得在前輩的程式上!
如有冒犯請見諒!也請前輩再指導!
教師節快樂!
Xl0000108_TESTv01_20240117_4.zip (530.58 KB)

下載次數: 2

2024-1-19 16:32

Sub CB2_Click()
Application.ScreenUpdating = False
    With Sheets("表單")
     .[A:I].UnMerge
     .[C1] = "XXX公司"
     .[C2] = "專特案明細表"
     .UsedRange.Offset(4, 0).EntireRow.Delete
     '↑1.(全部有使用的儲存格範圍偏移下方4列)刪除
     '↑2.偏移下方4列會框到沒有使用到的4列儲存格!刪除不影響結果!

     .ResetAllPageBreaks '重設分頁線
End With
Dim Arr, Brr(1 To 999, 1 To 9), Crr, xD, i&, j%, T1$, T2$, T3$, T4$, T5$, TT$, R&, N&, xA As Range
tm = Timer
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([總表!AM2], [總表!A1].Cells(Rows.Count, 1).End(3))
For i = 2 To UBound(Arr)
    T1 = Arr(i, 9) '專特案號 欄
    T2 = Arr(i, 12) '請購案號 欄
    T3 = Arr(i, 21) '專案預算 欄
    T4 = Arr(i, 23) '已給付金額 欄
    T5 = Arr(i, 25) '狀態 欄
    TT = T2 & "|" & T4 '請購案號 "|" 已給付金額
    If T1 = "" Or T2 = "無" Or T3 = "" Or xD(TT) > 0 Then
       '↑當i = 2:xD(TT) > 0 是用來檢測是否有(請購案號|已給付金額)重複__排除重覆
      
       GoTo i01
    End If
    Crr = xD(T1 & "/c")
    '↑當i = 2:先令Crr=字典裡的 專特案號+"/c"  (加"/c"字元防Part)
    '↑當i = 2:Crr是空的! 因Crr一開始是空的,xD("A2009001/c")字典裡也找不到!
    '↑當i >= 3:Crr已經是陣列了 因1.xD(T1 & "/c") = Crr ,2.工作表第3,4列專特案號都是A2009001
    '↑直到i = 50:也是工作表第51列 專特案號=A2104001,xD("A2104001/c")在字典裡是找不到的
    xD(TT) = 1
    '↑當i = 2:請購案號|已給付金額 倒入字典裡,item=1,讓i>=3 時排除重複
    '↑當i = 3:請購案號|已給付金額 倒入字典裡,item=1,讓i>=4 時排除重複
    '↑當i > 3:繼續倒入,讓前面排除重複
   
    xD(T1) = xD(T1) + 1
    '↑當i = 2:一開始將 第一種 專特案號(.KEY) 倒入字典.ITEM = 1
    ',ITEM也是後面要放入Crr的列號1
    '↑當i = 3:專特案號(.KEY) 字典已經有了.所以ITEM = 2
    '  ,ITEM也是後面要放入Crr的列號2,後面繼續倒入
    '↑直到i = 50:第二種 專特案號 倒入字典.ITEM = 1,後面繼續倒入
    '↑又直到i = 59:專特案號同第一種,第一種專特案號ITEM再加 1
   
    If Not IsArray(Crr) Then '判定Crr是不是陣列
       '↑當i = 2:一開始Crr不是陣列!只是空的
       '↑當i >= 3:Crr是陣列了!條件不成立,就跳到 End If
       '↑直到i = 50:Crr又不是陣列!又只是空的
       '↑到i = 59:Crr=xD(A2009001/c)是陣列條件不成立,就跳到 End If
      
       Crr = Brr
       '↑當i = 2:令Crr變成一個上述Brr(1 To 999, 1 To 9)空陣列
       '↑直到i = 50:再令Crr變成一個上述Brr(1 To 999, 1 To 9)空陣列
       '  ,所以Brr從頭到尾都是一個空的容器
      
       N = N + 1
       '↑當i = 2:一開始 N=1
       '↑直到i = 50:N=2
      
       xD(N) = T1
       '↑當i = 2:把第一種 專特案號 倒入字典裡,KEY = 1,ITEM = 第一種 專特案號
       '↑當第一種 專特案號就有兩筆資料在字典裡,先是一筆是1的KEY,另一筆是1的ITEM
       '↑當MsgBox T1 & " : " & xD(T1) & "  ,  " & N & " : " & xD(N)
       '↑直到i = 50:把第二種 專特案號 倒入字典裡,KEY = 2,ITEM = 第二種 專特案號
      
    End If
    For j = 1 To 9 'i = 2 設迴圈將資料帶入Crr陣列第一列
        Crr(xD(T1), j) = Arr(i, Array(9, 10, 11, 12, 22, 23, 24, 8, 5)(j - 1))
        '↑當i = 2:一開始 Crr(xD(T1), j) = Crr(1, j) 因為 xD(T1)=1
        '  ,Array()指定放入的欄位,(j - 1)是因為Array的第一筆索引是0
        '↑當i >= 3:專特案號都是A2009001,所以在前方xD(T1)都有加1  xD(T1) = xD(T1) + 1
        '↑直到i = 50:專特案號變成A2104001,xD(T1)變成1
        '↑到i = 59:專特案號又變成A2009001,所以xD("A2009001") ITEM在前方已繼續加1
        
    Next j
    xD(T1 & "/預算額") = Arr(i, 21) '預算金額
    '↑當i = 2 將 第一筆 專特案號+"/預算額" 倒入字典,ITEM=第一筆 (專特案號的 預算金額)
    '↑,+"/預算額" 是為了區隔前面的 第一筆專特案號 (原來字典裡已經有了)
    '↑當i >= 3 AND i < 50 :xD("A2009001/預算額")一直指向Arr(i, 21)
    '  ,如果預算有增減,都只抓最後一筆 專特案號的預算金額
    '↑當i >= 50 依此邏輯繼續判定
   
    xD(T1 & "/已付額") = xD(T1 & "/已付額") + Arr(i, 23) '已給付金額小計
    '↑當i = 2 將 第一筆 專特案號+"/已付額" 倒入字典,ITEM=第一筆 (專特案號的 已付額)
    '  ,加 "/已付額" 是為了區隔前面的 第一筆專特案號 (原來字典裡已經有了)
    '↑當i >= 3 AND i < 50 :xD("A2009001/已付額")一直指向Arr(i, 23)累加
    '↑當i >= 50 依此邏輯繼續判定
   
    If xD(T1 & "/" & T2) = 0 Then '專特案號/請購案號---排除重覆
       '同一個 專特案號/請購案號 的 請購金額 與 未付額 是相同的,所以須排除重複
       '↑當i = 2 :專特案號/請購案號 在字典是找不到的
       '↑當i= 3 :專特案號/請購案號 與i=2時相同 ITEM=1, IF的條件不成立
       '  ,排除重覆,就跳到 End If
       '↑當i > 3 依此邏輯繼續判定
      
       xD(T1 & "/請購額") = xD(T1 & "/請購額") + Arr(i, 22) '請購金額小計
       '↑當i = 2 將 第一筆 專特案號+"/請購額" 倒入字典
       '  ,ITEM= 0 + 第一筆 (專特案號的 請購額)  0是因為原字典裡的ITEM是0
       '  ,加 "/請購額" 是為了區隔前面的 第一筆專特案號 (原來字典裡已經有了)
       '↑當i > 3 依此邏輯繼續判定,xD(T1 & "/請購額")指向Arr(i, 22)累加
      
       xD(T1 & "/未付額") = xD(T1 & "/未付額") + Arr(i, 24) '未給付金額小計
       '↑當i = 2 將 第一筆 專特案號+"/未付額" 倒入字典
       '  ,ITEM= 0 + 第一筆 (專特案號的 未付額)  0是因為原字典裡的ITEM是0
       '  ,加 "/未付額" 是為了區隔前面的 第一筆專特案號 (原來字典裡已經有了)
       '↑當i > 3 依此邏輯繼續判定,xD(T1 & "/未付額")指向Arr(i, 24)累加
      
       xD(T1 & "/" & T2) = 1
       '↑當i = 2 將 專特案號/請購案號 倒入字典,ITEM=1
       '↑當i > 3:繼續倒入,讓前面排除重複
      
    End If
    xD(T1 & "/c") = Crr
    '↑當i = 2 把第一筆的 專特案號+"/c" 倒入字典,ITEM= Crr陣列
    '  所以xD字典裡裝了文字.數字還有陣列
    '↑當i >= 3:Crr陣列又多了一列資料,且又讓給xD(T1 & "/c")來裝,ITEM= Crr陣列
   
i01: Next i
'迴圈總結
'1.N=2,因為只有兩種專特案號,而且字典裡也加序號 與 專特案號
'  KEY=1:ITEM=A2009001,KEY=2:ITEM=A2104001
'2.xD("A2009001")已累積到59,xD("A2104001")已累積到17

'--------------------------------
Application.ScreenUpdating = False
Set xA = [表單!A1]
'↑令 xA是 "表單" 工作表.[A1]儲存格,所以xA已經指向Sheets("表單")

[表單!C1:H1].Merge: [表單!C2:H2].Merge: [表單!C3:H3].Merge
For i = 1 To N
    If i > 1 Then [表單!A1:I4].Copy xA
    T1 = xD(i)
    '↑當N = 1,T1=A2009001
    '↑當N = 2,T1=A2104001
   
    R = xD(T1)
    '↑當N = 1,R=59
    '↑當N = 2,R=17
   
    Crr = xD(T1 & "/c")
    '↑從字典裡把兩個陣列帶出來
   
    xA(3, 2) = T1
    '↑因xA已經指向Sheets("表單"),所以xA(3, 2)=Sheets("表單").[B3]
   
    xA(1, 9) = "項次:" & i & "/" & N
    With xA(5).Resize(R, 9)
         [表單!A4:I4].Copy .Cells
         .Value = Crr
    End With
    xA(R + 5, 4) = "小計"
    xA(R + 5, 5) = xD(T1 & "/請購額") '請購金額小計
    xA(R + 5, 6) = xD(T1 & "/已付額") '已給付金額小計
    xA(R + 5, 7) = xD(T1 & "/未付額") '未給付金額小計
    '-------------------------------------------------------
    xA(3, 3) = "截止日期:" & Format([總表!C1], "yyyy/m/d")
    xA(1, 2) = xD(T1 & "/預算額") '預算總額
    xA(2, 2) = xD(T1 & "/預算額") - xD(T1 & "/請購額") '剩餘額度
    Set xA = xA(R + 6)
    xA.PageBreak = xlPageBreakManual '設定分頁線
Next i
Set xD = Nothing: Erase Arr, Brr, Crr
    Sheets("表單").Activate
        [C3].Select
        [H:H].NumberFormatLocal = "yyyy/mm/dd"
        [E:G].NumberFormatLocal = "* #,##0"
        [A:C].NumberFormatLocal = "_($* #,##0_);[紅色]_($* (#,##0);_(@_)"
    MsgBox Timer - tm
Application.ScreenUpdating = Ture
End Sub

shuo1125

回復 36# Andy2483
Andy2483前輩好！
准大的思路真的高深莫測，我也是經過好久才能大概理解怎調整來運行....
今天您特地關注此帖還為程式碼註解讓我也能一同學習，論壇的各位前輩無私的奉獻真的讓人感動。

Andy2483

回復 37# shuo1125


    前輩早安
這字典除精準到位!
迂迴瀏覽!像會動的風景油畫般藝術品!
key像水岸,item像河!
天空天鵝陸續飛到水岸上
T1 = Arr(i, 9) '專特案號 欄
T2 = Arr(i, 12) '請購案號 欄
T3 = Arr(i, 21) '專案預算 欄
T4 = Arr(i, 23) '已給付金額 欄
T5 = Arr(i, 25) '狀態 欄
TT = T2 & "|" & T4 '請購案號 "|" 已給付金額
TT是情侶,成雙成對!海枯石爛! 可是中間有小三 T3
時而T1天鵝走向河邊,呈現水中倒影!
xD(T1) = xD(T1) + 1 :  xD(N) = T1
時而母鵝帶小鵝,
For j = 1 To 9

又像電影般
xD(T1 & "/預算額") = Arr(i, 21) '預算金額
xD(T1 & "/已付額") = xD(T1 & "/已付額") + Arr(i, 23) '已給付金額小計
說T1風流! 最終情定 T2 至死不渝
xD(T1 & "/" & T2) = 1

多點欣賞多點想像力!學習更有趣!
以後應用更有印象!
謝謝麻辣家族討論版版優質平台!
謝謝各位前輩!

Andy2483

回復 37# shuo1125
心得與前輩分享
Crr = xD(T1 & "/c")
~
xD(T1 & "/c") = Crr
本來很納悶這兩行個都是陣列!為什麼要倒來倒過去的!
練習了一主題的範例初步得到結論:
1.直接在字典裡裡面的陣列值引用或編輯很耗時間
2.反而把陣列提取出來做陣列值引用或編輯比較快
3.資料少差異不大!上千筆以上就差很多了!
列出更多資料_20221020_8_2.zip (41.54 KB)

下載次數: 4

2022-10-20 11:23

准大的設計涵蓋比較廣:

下載 (302.45 KB)

2022-10-20 11:24

後學研究一個涵蓋少的,在字典外編輯:

下載 (360.04 KB)

2022-10-20 11:25

後學把陣列資料放在字典裡直接編輯:

下載 (431.07 KB)

2022-10-20 11:27

shuo1125

回復 39# Andy2483
Andy2483前輩好！
准大的思路都是尋求最高效率，最精簡的程式碼，
一段簡單的語言涵蓋了很多高深技巧，但能運用得當難度真的很高..
您研究的真的很透徹...更難能可貴的是不吝分享，
對我這新手受益良多，感謝您的指導！