- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-3-24
|
3#
發表於 2024-2-7 13:27
| 只看該作者
回復 1# 198188
謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,這範例好難,各段落明細的列順序找不到規則,學習方案如下,請前輩參考
Option Explicit
Sub TEST()
Dim Brr(1 To 100, 1 To 14), A, Z, Q, P, i&, j%, R&, C%, N&, x%, T$, T14$, T15$, T5$, V8&, V9&, V10#, Tp1$, Tp3$, Tp5$, Y&
Dim PGNr, Rackr, Itemr, PGr, DPLs As Worksheet, xR As Range, xRs As Range, xRe As Range
Set Z = CreateObject("Scripting.Dictionary"): Application.ScreenUpdating = False
PGNr = [PGN!A1].CurrentRegion: Rackr = [Rack!A1].CurrentRegion: Itemr = [Item!A1].CurrentRegion: PGr = [PG!A1].CurrentRegion
Set DPLs = Sheets("DPL"): DPLs.Activate: T = [J3]: DPLs.UsedRange.Offset(19).EntireRow.Delete: Set xR = [A20]: xR.Resize(1000, 14).Borders.LineStyle = 1
For i = 2 To UBound(PGr)
If Z(PGr(i, 1) & "^") = "" Then Z(PGr(i, 1) & "^") = PGr(i, 2) Else MsgBox "PG表 " & PGr(i, 1) & " 重複": Exit Sub
Next
For i = 2 To UBound(Rackr)
If Rackr(i, 11) <> T Then GoTo i01
T14 = Rackr(i, 14): T5 = Rackr(i, 5): T15 = Rackr(i, 15)
If Not Z.Exists(T15) Then R = N Mod 3 + 1: C = N \ 3: N = N + 1: Brr(R, Array(1, 3, 4)(C)) = T15: Z(T15) = ""
If InStr("," & Z(T14 & "/GD") & ",", "," & T15 & ",") = 0 Then Z(T14 & "/GD") = Z(T14 & "/GD") & "," & T15
If InStr("," & Z(T14 & "/RN") & ",", "," & T5 & ",") = 0 Then Z(T14 & "/RN") = Z(T14 & "/RN") & "," & T5: Z(T5 & "|") = i Else MsgBox "Rack表 " & T5 & " 重複": Exit Sub
i01: Next
DPLs.[G12].Resize(3, 4) = Brr: DPLs.[G15] = "TOTAL " & N & " X 45'HC CONTAINER": N = 0
For i = 2 To UBound(PGNr)
If PGNr(i, 1) <> T Then GoTo i02
If Z.Exists(PGNr(i, 2) & "/GD") Then Z(PGNr(i, 2) & "/GD") = "CONTAINER NO.:" & Mid(Z(PGNr(i, 2) & "/GD"), 2) & vbCrLf & PGNr(i, 3) ': MsgBox Z(PGNr(i, 2) & "/GD")
i02: Next
For i = 2 To UBound(Itemr)
If Z.Exists(Itemr(i, 3) & "|") Then Z(Itemr(i, 3) & "|") = Z(Itemr(i, 3) & "|") & "," & i
Next
For Each A In Z.KEYS
If Right(A, 3) <> "/RN" Then GoTo A01 Else Q = Split(Z(A), ","): xR = Z(Split(A, "/RN")(0) & "/GD")
With xR.Resize(, 14): .Merge: .Font.Size = 9: .Font.Bold = True: .Rows.RowHeight = 52: End With
For i = 1 To UBound(Q)
Set xR = xR(2): xR.Resize(1, 14).Interior.ColorIndex = 15: xR.Resize(1, 14).Font.Bold = True
With xR.Resize(1, 4): .Merge: .Font.Size = 12: .Value = "'" & Q(i): End With
xR(1, 6).Resize(, 2).Merge: xR(1, 10).Resize(, 5).Merge
P = Split(Z(Q(i) & "|"), ","): R = Val(P(0))
xR(1, 8) = Val(Rackr(R, 6)): xR(1, 9) = Val(Rackr(R, 7)): xR(1, 10) = Rackr(R, 8) & " x " & Rackr(R, 9) & " x " & Rackr(R, 10)
V8 = V8 + xR(1, 8): V9 = V9 + xR(1, 9): V10 = V10 + (Val(Rackr(R, 8)) * Val(Rackr(R, 9)) * Val(Rackr(R, 10)) / 10 ^ 9): Set xRs = xR(2, 8): Set xRe = xR(2, 1)
For j = 1 To UBound(P)
Tp1 = Itemr(P(j), 5): Tp3 = Z(Itemr(P(j), 6) & "^"): Tp5 = Itemr(P(j), 4)
Y = Z(Q(i) & "/" & Tp1 & "/" & Tp3 & "/" & Tp5)
If Y = 0 Then
Set xR = xR(2): xR.Resize(1, 14).Font.Size = 9: xR = Tp1: xR(1, 3) = Tp3: xR(1, 5) = Tp5: xR(1, 6) = Val(Itemr(P(j), 7))
Z(Q(i) & "/" & Tp1 & "/" & Tp3 & "/" & Tp5) = xR.Row: GoTo j01
End If
Cells(Y, 6) = Cells(Y, 6) + Val(Itemr(P(j), 7))
j01: Next
With Range(xRe, xR(1, 14))
.Sort KEY1:=.Item(6), Order1:=1, Header:=2: .Sort KEY1:=.Item(5), Order1:=1, Key2:=.Item(3), Order2:=1, Key3:=.Item(1), Order2:=1, Header:=2
For R = 1 To .Rows.Count: .Cells(R, 1).Resize(1, 2).Merge: .Cells(R, 3).Resize(1, 2).Merge: .Cells(R, 6).Resize(1, 2).Merge: Next
End With
Range(xRs, xR(1, 14)).Merge
Next
Set xR = xR(2)
A01: Next
Set xR = xR(2): xR(1, 5) = "TOTAL": xR(1, 8) = V8: xR(1, 9) = V9: xR(1, 10) = V10: xR(1, 10).Resize(1, 5).Merge
With xR.Resize(1, 14): .Font.Size = 12: .Font.Bold = True: End With
Set Z = Nothing: Erase PGNr, Rackr, Itemr, PGr
End Sub
祝各位前輩 新春愉快 |
|
