- 帖子
- 1446
- 主題
- 40
- 精華
- 0
- 積分
- 1470
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-10-21
|
36#
發表於 2022-9-28 16:31
| 只看該作者
本帖最後由 Andy2483 於 2024-1-19 16:33 編輯
回復 31# 准提部林
謝謝前輩指導
後學駑鈍! 學習您的範例真的很難!
註解心得在前輩的程式上!
如有冒犯請見諒!也請前輩再指導!
教師節快樂!
 Xl0000108_TESTv01_20240117_4.zip (530.58 KB)
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 |
|
發表於 2022-9-24 15:56
| 
