Board logo

標題: [發問] 請教 以字典抓取符合條件資料後輸出 [打印本頁]
作者: shuo1125    時間: 2021-11-23 22:08     標題: 請教 以字典抓取符合條件資料後輸出

各位前輩好，
若想以CreateObject("Scripting.Dictionary")字典方式抓取資料並將結果輸出，請問程式該如何寫..
(如圖檔及附檔)

以[盤點表]為模板，符合下列條件時，將DATA結果輸出如[盤點表(結果)]
1.當DATA所在地=盤點表B2時。
2.若遇到財產編號相同者，只列出頭一筆。
3.將各所在地之資料分別輸出，以分頁區分。
4.在最後進行各所在地數量小計。
5.有資料部分才框線。

以上，因資料有部分隱私，故只擷取部分檔案，性質雷同只是筆數多很多。

想請問有高手可以幫忙解答嗎，
麻煩了，謝謝！
作者: 准提部林    時間: 2021-11-24 11:29

1.當DATA所在地=盤點表B2時。
__B2底下還有其它"所在地", 怎解??

2.若遇到財產編號相同者，只列出頭一筆。
__只列一筆, 要不要累計?

3.將各所在地之資料分別輸出，以分頁區分。
__若同一所在地, 資料行數太多, 列印超過一頁, 怎解??
作者: shuo1125    時間: 2021-11-24 11:39

回復 2# 准提部林
准大您好！
可能是我意思表達不清...如下回覆。

1.當DATA所在地=盤點表B2時。
__B2底下還有其它"所在地", 怎解??
->這部份是我表達不清楚..其實就是要列出各所在地資料，只是所在地會表達在盤點表B2。

2.若遇到財產編號相同者，只列出頭一筆。
__只列一筆, 要不要累計?
->不需累計，當成一筆就好。

3.將各所在地之資料分別輸出，以分頁區分。
__若同一所在地, 資料行數太多, 列印超過一頁, 怎解??
->若超過該行數，就列於第二、三頁以此類推...但若為不同所在地，是否就能接續在下頁中？

以上，麻煩了，謝謝。
作者: samwang    時間: 2021-11-24 13:45

回復 1# shuo1125

請測試看看，謝謝
作者: samwang    時間: 2021-11-24 14:01

回復 3# shuo1125

3.將各所在地之資料分別輸出，以分頁區分。
__若同一所在地, 資料行數太多, 列印超過一頁, 怎解??
->若超過該行數，就列於第二、三頁以此類推...但若為不同所在地，是否就能接續在下頁中？
>> 可以，但是處理會比較複雜麻煩；4#是沒有考慮的超過1頁的問題
       建議:將每個各所在地，獨立放在個別新增工作表，不知是否可以?
作者: samwang    時間: 2021-11-24 16:39

回復 3# shuo1125


3.將各所在地之資料分別輸出，以分頁區分。
__若同一所在地, 資料行數太多, 列印超過一頁, 怎解??
->若超過該行數，就列於第二、三頁以此類推...但若為不同所在地，是否就能接續在下頁中？
>> 接續下頁中，請測試看看，謝謝   
作者: shuo1125    時間: 2021-11-24 17:09

回復 6# samwang

samwang大大您好！

3.將各所在地之資料分別輸出，以分頁區分。
__若同一所在地, 資料行數太多, 列印超過一頁, 怎解??
->若超過該行數，就列於第二、三頁以此類推...但若為不同所在地，是否就能接續在下頁中？
>> 可以，但是處理會比較複雜麻煩；4#是沒有考慮的超過1頁的問題
       建議:將每個各所在地，獨立放在個別新增工作表，不知是否可以?
>>>若將所在地放至不同工作表也可並無強制...因以分頁模式處裡似乎困難度很高..剛跑似乎資料是有出來的
目前暫不確定資料量大時是否分頁會亂掉..因你又有幫忙寫一版，我晚點在測試完整版與原筆數是否正確。

謝謝你這麼有效率的幫忙處理及回覆...由衷感謝！
作者: shuo1125    時間: 2021-11-24 21:51

本帖最後由 shuo1125 於 2021-11-24 21:57 編輯

回復 6# samwang

samwang好！
[attach]34435[/attach][attach]34434[/attach]
建議:將每個各所在地，獨立放在個別新增工作表，不知是否可以?
>若以此方法做，請問該怎麼修正..?因測試後發現分頁會錯置以及有部分資料未帶入(如圖片)

另外有幾個問題想請問
一、T1 = T & "|" & Arr(i, 6)
     >這一段是判斷是否有符合財產編號嗎? "|"這個的用意是..?
二、xD1(T1) = 1: xD1(T & "/1") = xD1(T & "/1") + Arr(i, 14)
     >這段用法太高深..能夠解釋一下嗎?
三、將資料存入Arr陣列中時，此時Arr是視為物件嗎?字典xD也是物件嗎?有點無法理解...

以上，在煩請撥冗解答了..感謝！
作者: samwang    時間: 2021-11-25 09:39

回復 8# shuo1125

建議:將每個各所在地，獨立放在個別新增工作表，不知是否可以?
>若以此方法做，請問該怎麼修正..?因測試後發現分頁會錯置以及有部分資料未帶入(如圖片)
>> 如附件，請測試看看，如果還有資料未帶出來，請再上傳附件，謝謝
作者: shuo1125    時間: 2021-11-25 10:22

回復 9# samwang

samwang大大好！

經測試資料已無誤，上述問題若您有空再解答，如沒有就不耽擱你時間了...
非常感謝你撥空幫忙處理！
作者: samwang    時間: 2021-11-25 10:24

本帖最後由 samwang 於 2021-11-25 10:25 編輯

回復 8# shuo1125

另外有幾個問題想請問
一、T1 = T & "|" & Arr(i, 6)
      >這一段是判斷是否有符合財產編號嗎? >> 若遇到財產編號相同者，只列出頭一筆。
        "|"這個的用意是..? >> 串聯2個值中間的符號，可換成其它符號皆可
二、xD1(T1) = 1: xD1(T & "/1") = xD1(T & "/1") + Arr(i, 14)
      >這段用法太高深..能夠解釋一下嗎?  >> 小記數量
三、將資料存入Arr陣列中時，此時Arr是視為物件嗎?字典xD也是物件嗎?有點無法理解...
       >>不好意思，不太知道那些定義用詞，後學是半路出家的，看了網上前輩寫法，就一樣畫葫蘆
作者: shuo1125    時間: 2021-11-25 18:05

回復 11# samwang

感謝samwang大大幫忙解答

能理解並用於實例已是我所不及⋯
再次感謝您的幫忙！！
作者: 准提部林    時間: 2021-11-25 21:58

若資料多, 且每所在地的項目不超過999種, 可參考此方法:
放在同一頁, 每所在地底下加"分頁線", 使用預覽即可明白:
[attach]34440[/attach]
作者: shuo1125    時間: 2021-11-26 08:53

回復 13# 准提部林

准大好！
因某些因素暫時無法做測試⋯
也感謝您花費精力及時間幫忙
感激不盡！
作者: 准提部林    時間: 2021-11-28 11:17

再發一版--純篩選複製至各分表:
[attach]34444[/attach]
作者: 准提部林    時間: 2021-11-28 18:12

少算一行:
.Rows(1).Resize(.Rows.Count ).Copy xS.[a4]
改成
.Rows(2).Resize(.Rows.Count - 1).Copy xS.[a4]
作者: shuo1125    時間: 2021-11-29 18:41

回復 16# 准提部林

准大好！
經測試後兩種方式都無誤，
還特地花時間提供不同方法，
太感謝你了。
作者: shuo1125    時間: 2021-12-2 22:20

本帖最後由 shuo1125 於 2021-12-2 22:23 編輯

回復 16# 准提部林

准大好！
不好意思，突然想到個問題，如果我AT欄只想抓空白資料，這樣要如何多寫條件進去...
(因該欄會有S=銷售 R=報廢 O=其他等字碼，但這部分要排除)

附上圖[attach]34458[/attach]

可以再麻煩抽空幫忙解答嗎?

謝謝。
作者: 准提部林    時間: 2021-12-4 13:26

回復 18# shuo1125

Sub TEST_A4()
Dim Arr, Brr, Cr, xD, vD, i&, j%, R&, K, T1$, T2$, TT$, N&, V%, xA As Range
tm = Timer
Call 清除
Set xD = CreateObject("Scripting.Dictionary")
Set vD = CreateObject("Scripting.Dictionary")
Arr = Range([DATA!at1], [DATA!a65536].End(xlUp))
For i = 2 To UBound(Arr)
    If Arr(i, 46) <> "" Then GoTo i01   
    T1 = Arr(i, 11): T2 = Arr(i, 6): TT = T1 & T2
    If T1 = "" Or T2 = "" Or xD(TT) > 0 Then GoTo i01
    If xD(T1) = 0 Then Set vD(T1) = CreateObject("Scripting.Dictionary")
    xD(T1) = 1: xD(TT) = 1: vD(T1)(i) = ""
i01: Next i
'--------------------------------
Application.ScreenUpdating = False
Set xA = [盤點表!A1]: Cr = Array(1, 3, 6, 8, 10, 14, 13, 12)
For Each K In vD.keys
    R = vD(K).Count: N = N + 1
    ReDim Brr(1 To R + 1, 1 To 10)
    For i = 1 To R
        V = vD(K).keys()(i - 1)
        Brr(i + 1, 5) = "小計：": Brr(i + 1, 8) = Brr(i, 8) + Arr(V, 12)
        For j = 1 To 8:  Brr(i, j) = Arr(V, Cr(j - 1)): Next
    Next i
    [盤點表!A1:j3].Copy xA
    xA(2, 2) = K: xA(2, 10) = "頁次：" & N & "/" & vD.Count
    [盤點表!a4:j4].Copy xA(4).Resize(R, 10)
    xA(4).Resize(R + 1, 10).Value = Brr
    Set xA = xA(R + 5): xA.PageBreak = xlPageBreakManual '設定分頁線
Next
MsgBox Timer - tm
End Sub
作者: shuo1125    時間: 2021-12-6 19:57

回復 19# 准提部林

准大好！

感謝您的解答與答覆，
測試已OK。

祝您順心~
作者: shuo1125    時間: 2021-12-9 21:43

回復 19# 准提部林

准大好！

附上圖[attach]34493[/attach]
不好意思再請教個問題...如果有資料的部分J欄想增加"口人員 口地點 口功能"這些文字
請問該如何修改好，可煩請再指導一下嗎?

勞煩您抽空解答了，謝謝。
作者: 准提部林    時間: 2021-12-10 20:26

回復 21# shuo1125

    For i = 1 To R
        V = vD(K).keys()(i - 1)
        Brr(i + 1, 5) = "小計：": Brr(i + 1, 8) = Brr(i, 8) + Arr(V, 12)
        For j = 1 To 8:  Brr(i, j) = Arr(V, Cr(j - 1)): Next
        Brr(i, 10) = "口人員 口地點 口功能"
    Next i
作者: shuo1125    時間: 2021-12-10 21:02

回復 22# 准提部林
准大好！
不好意思...好像有點怪怪的
For i = 1 To R
        V = vD(K).keys()(i - 1)
        Brr(i + 1, 5) = "小計：": Brr(i + 1, 8) = Brr(i, 8) + Arr(V, 12)
        For j = 1 To 8:  Brr(i, j) = Arr(V, Cr(j - 1)): Next
'好像沒有上述這一段...
----------------------------------------------------------------------------------------------------------------
    Set xA = [盤點表單!A1]
For i = 1 To N
    If i > 1 Then [盤點表單!A1:K3].Copy xA
    T1 = xD(i): R = xD(T1): Crr = xD(T1 & "/c")
    xA(2, 2) = T1: xA(2, 11) = "項次：" & i & "/" & N
    With xA(4).Resize(R, 11)
         [盤點表單!A4:K4].Copy .Cells
         .Value = Crr
    End With
    xA(R + 4, 2) = "會盤人：": xA(R + 4, 4) = "盤點人：": xA(R + 4, 5) = "小計": xA(R + 4, 9) = xD(T1 & "/s")
    Set xA = xA(R + 5)
    xA.PageBreak = xlPageBreakManual '設定分頁線
'是上面這段
----------------------------------------------------------------------------------------------------------------
還是我放的位置有錯...麻煩在指正一下
勞煩你了，謝謝。
作者: 准提部林    時間: 2021-12-10 21:10

回復 23# shuo1125

Sub TEST_A4()
Dim Arr, Brr, Cr, xD, vD, i&, j%, R&, K, T1$, T2$, TT$, N&, V%, xA As Range
tm = Timer
Call 清除
Set xD = CreateObject("Scripting.Dictionary")
Set vD = CreateObject("Scripting.Dictionary")
Arr = Range([DATA!at1], [DATA!a65536].End(xlUp))
For i = 2 To UBound(Arr)
    If Arr(i, 46) <> "" Then GoTo i01
    T1 = Arr(i, 11): T2 = Arr(i, 6): TT = T1 & T2
    If T1 = "" Or T2 = "" Or xD(TT) > 0 Then GoTo i01
    If xD(T1) = 0 Then Set vD(T1) = CreateObject("Scripting.Dictionary")
    xD(T1) = 1: xD(TT) = 1: vD(T1)(i) = ""
i01: Next i
'--------------------------------
Application.ScreenUpdating = False
Set xA = [盤點表!A1]: Cr = Array(1, 3, 6, 8, 10, 14, 13, 12)
For Each K In vD.keys
    R = vD(K).Count: N = N + 1
    ReDim Brr(1 To R + 1, 1 To 10)
    For i = 1 To R
        V = vD(K).keys()(i - 1)
        Brr(i + 1, 5) = "小計：": Brr(i + 1, 8) = Brr(i, 8) + Arr(V, 12)
        For j = 1 To 8:  Brr(i, j) = Arr(V, Cr(j - 1)): Next
        Brr(i, 10) = "口人員 口地點 口功能"
    Next i
    [盤點表!A1:j3].Copy xA
    xA(2, 2) = K: xA(2, 10) = "頁次：" & N & "/" & vD.Count
    [盤點表!a4:j4].Copy xA(4).Resize(R, 10)
    xA(4).Resize(R + 1, 10).Value = Brr
    Set xA = xA(R + 5): xA.PageBreak = xlPageBreakManual '設定分頁線
Next
MsgBox Timer - tm
End Sub
作者: 准提部林    時間: 2021-12-10 21:13

回復 23# shuo1125


Sub TEST_A1()
Dim Arr, Brr(1 To 999, 1 To 10), Crr, xD, i&, j%, T1$, T2$, TT$, R&, N&, xA As Range
tm = Timer
Call 清除
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([DATA!at1], [DATA!a65536].End(xlUp))
For i = 2 To UBound(Arr)
    If Arr(i, 46) <> "" Then GoTo i01
    T1 = Arr(i, 11): T2 = Arr(i, 6): TT = T1 & "|" & T2
    If T1 = "" Or T2 = "" Or xD(TT) > 0 Then GoTo i01
    Crr = xD(T1 & "/c"): xD(TT) = 1: xD(T1) = xD(T1) + 1
    If Not IsArray(Crr) Then Crr = Brr: N = N + 1: xD(N) = T1
    For j = 1 To 8
        Crr(xD(T1), j) = Arr(i, Array(1, 3, 6, 8, 10, 14, 13, 12)(j - 1))
    Next j
    Crr(xD(T1), 10) = "口人員 口地點 口功能"
    xD(T1 & "/s") = xD(T1 & "/s") + Arr(i, 12) '數量小計
    xD(T1 & "/c") = Crr
i01: Next i
'--------------------------------
Application.ScreenUpdating = False
Set xA = [盤點表!A1]
For i = 1 To N
    If i > 1 Then [盤點表!A1:j3].Copy xA
    T1 = xD(i): R = xD(T1): Crr = xD(T1 & "/c")
    xA(2, 2) = T1: xA(2, 10) = "頁次：" & i & "/" & N
    With xA(4).Resize(R, 10)
         [盤點表!a4:j4].Copy .Cells
         .Value = Crr
    End With
    xA(R + 4, 5) = "小計": xA(R + 4, 8) = xD(T1 & "/s")
    Set xA = xA(R + 5)
    xA.PageBreak = xlPageBreakManual '設定分頁線
Next i
Set xD = Nothing: Erase Arr, Brr, Crr
MsgBox Timer - tm
End Sub
作者: shuo1125    時間: 2021-12-10 21:22

回復 25# 准提部林
准大好！

可以了，謝謝你屢次不吝的完整回答..

感激不盡，祝您順心~
作者: shuo1125    時間: 2022-2-11 13:53

回復 25# 准提部林

准大好！
抱歉再追問...
請問若我希望呈現結果為每頁都有抬頭及標題，
程式碼該如何修正？
附上附檔及圖片(因有機密資料故附檔為範例)
麻煩在抽空協助了，感激不盡！
作者: 准提部林    時間: 2022-2-13 14:53

本帖最後由 准提部林 於 2022-2-13 14:55 編輯

回復 27# shuo1125

這種列印方法, 非常麻煩, 只以目前的列印設定為準, 表首3行+表身27行--為一頁,
若有變動, 自行去調整(先調整列印設定, 再去抓表身行數)
[attach]34670[/attach]

列印設定如果放在程式中, 速度會變得很久, 有時久到像當機, 最好避免, 應手動事先設好設滿~~讓程式只處理數據就好
程式增加三欄輔助(執行後自動清除)--作為排序及表首+頁次的處理, 否則執行太慢~~
作者: shuo1125    時間: 2022-2-13 16:43

回復 28# 准提部林

准大好！
其實是後來想到在實際列印紙本清點時，
沒有抬頭真的會不太好看...但又想不出如何調整...
沒想到您幫忙之餘還能想到程式運行速度及調整內容，
真是太專業了，但程式碼我還需花時間研究一下...
若有問題屆時再勞煩你不吝指導了，
謝謝！
作者: shuo1125    時間: 2022-9-20 11:15

回復 28# 准提部林
准大好！
經前段您指導的程式碼，我修改成符合使用後遇到以下問題，可否煩請抽空協助指導如何修正...
問題A→B2=預算總額-請購總額。
問題B→小計部分的請購總額及未給付總額有辦法得出嗎?(因請購單會有重複之狀況。)
或是有其他前輩可抽空指導…
以上，麻煩大家了！
若文字敘述不清，可看附檔及圖檔。
[attach]35222[/attach][attach]35224[/attach]
作者: 准提部林    時間: 2022-9-24 15:56

回復 30# shuo1125

稍改
[attach]35236[/attach]
作者: shuo1125    時間: 2022-9-24 16:58

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

回復 32# shuo1125


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

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

回復 34# shuo1125


    前輩們教師節快樂!
每位前輩都有後學可以學習的!都是後學的老師!
謝謝前輩發表此主題與範例!
後學藉題學習,如有冒犯,請見諒!
作者: Andy2483    時間: 2022-9-28 16:31

本帖最後由 Andy2483 於 2024-1-19 16:33 編輯

回復 31# 准提部林


    謝謝前輩指導
後學駑鈍! 學習您的範例真的很難!
註解心得在前輩的程式上!
如有冒犯請見諒!也請前輩再指導!
教師節快樂!
[attach]37320[/attach]

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    時間: 2022-9-29 21:02

本帖最後由 shuo1125 於 2022-9-29 21:04 編輯

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

回復 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    時間: 2022-10-20 11:28

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

准大的設計涵蓋比較廣:
[attach]35352[/attach]

後學研究一個涵蓋少的,在字典外編輯:
[attach]35353[/attach]

後學把陣列資料放在字典裡直接編輯:
[attach]35354[/attach]
作者: shuo1125    時間: 2022-10-20 21:47

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



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