Andy2483

¦^´_ 1# 198188


    ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,³o½d¨Ò¦nÃø,¦U¬q¸¨©ú²Óªº¦C¶¶§Ç§ä¤£¨ì³W«h,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

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

¯¬¦U¦ì«e½ú ·s¬K´r§Ö

Andy2483

¦^´_ 5# 198188

¥ý¬Ý¬Ý°õ¦æ«á¬O§_¬°»Ý¨Dªº¦C¦L¤À­¶,¦A¬Ý¬Ý«áÄò¦p¦ó¸Ñ
20240219_4.zip (177.64 KB)

¤U¸ü¦¸¼Æ: 6

2024-2-19 11:58

Andy2483

¦^´_ 8# 198188


    ³o¼Ë¦^´_µLªk½T»{¤À­¶¬O§_¥¿½T,¦pªG¦A½Õ¾ã¹LÄæ¼e©Î¤ñ¨Ò´N±o­«ºâ°Ñ¼Æ
¥H¤Uªþ¥ó¬O7#Àɮ׶ץXPDFÀɪºµ²ªG,»P8#¦^´_Âû¦PÀnÁ¿
20240219_4.zip (186.6 KB)

¤U¸ü¦¸¼Æ: 3

2024-2-19 15:15

¥H¤U¬O«á¾Ç¤À­¶¹wÄýªºª¬ªp:

¤U¸ü (83.41 KB)

2024-2-19 15:22

Andy2483

¦^´_ 10# 198188


7#ªº½d¨Ò¥u¬O·Q¥ý½T»{¤À­¶¬O§_¥¿½T,¦pªG¤À­¶²Å¦X»Ý¨D¦A³B²z®Ø½u¤Î¸É²Ä¤@¦CªÅ¥Õ®æ°ÝÃD
¦C¦L¸òEXCELª©¥»¤Î¨ä¥¦°Ñ¼Æ¦³Ãö

Andy2483

¦^´_ 10# 198188

¬Ý¬ÝÁÙ·|¤£·| "«á¤@¦æ±À¨ì²Ä¤G­¶"...µ¥°ÝÃD,¦pªG¤À­¶¥¿½T¦AÄ~Äò
20240219_6.zip (177.01 KB)

¤U¸ü¦¸¼Æ: 3

2024-2-19 16:44

Andy2483

¦^´_ 14# 198188


    ¬Ý³oºI¹Ïµe­±¦n¹³¬O±z´ú¸ÕªºÀɤ£¤@¼Ë¡A¨Ã¤£¬O¥Î«á¾Ç¤W¶ÇªºÀÉ®×
»P¨ä¶Ã²q¤£¦p½Ð¤W¶Ç¹ê»Ú­n´ú¸ÕªºÀÉ®×

Andy2483

¦^´_ 16# 198188


    ²{¦b¨S¦³PC¥i¥H´ú¸Õ¡A«e½ú¥i¥H½Õ¾ãµ{¦¡³Ì«á¦³­Ó1.35ªº°Ñ¼Æ §â¥¦¸Õ§ï¬°1.3 ©Î 1.25¦A°õ¦æ¬Ý¬Ý

Andy2483

¦^´_ 18# 198188

ÁÂÁ½׾Â,ÁÂÁ«e½ú¦^´_
«á¾ÇÂǦ¹©«¾Ç²ß¨ì«Ü¦hª¾ÃÑ,¾Ç²ßªº¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò
20240220_10.zip (150.23 KB)

¤U¸ü¦¸¼Æ: 3

2024-2-20 14:21

Andy2483

¦^´_ 20# 198188


Àx¦s®æO1ªº1.35 §ï¬°1.3 ¸Õ¸Õ¬Ý
§Ú§Ñ°O¤F²Å骩·|¶Ã½X¡A¤£¼vÅT°õ¦æ´N¨SÃö¨t

Andy2483

¦^´_ 22# 198188


    Àx¦s®æO1
¦bªí®æªºO1¤W¬O1.35§ï¬° 1.3 ¸Õ¸Õ¬Ý

¤U¸ü (94.37 KB)

2024-2-21 07:07

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&, SS$, Tts#
Dim PGNr, Rackr, Itemr, PGr, DPLs As Worksheet, xR As Range, xRs As Range, TT$, TH#, ii, RH, Sh#, xRc As Range, xRe As Range
Set Z = CreateObject("Scripting.Dictionary"): Application.ScreenUpdating = False: Application.DisplayAlerts = False: Sh = Rows(17).RowHeight / 32
Tts = [O1]: 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]
Cells.VerticalAlignment = xlCenter: ActiveSheet.ResetAllPageBreaks: [A1].Activate: For i = 1 To 19: TH = TH + Rows(i).RowHeight: Next
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)
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 * Sh: 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: xR.Rows.RowHeight = 27 * Sh
      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 xRs = 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: xR.Rows.RowHeight = 27 * Sh: GoTo j01
         End If
         Cells(Y, 6) = Cells(Y, 6) + Val(Itemr(P(j), 7))
j01:  Next
      With Range(xRs, 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: .Cells(R, 8).Resize(1, 7).Merge: Next
      End With
   Next
   Set xR = xR(2)
A01: Next
Cells.VerticalAlignment = xlCenter: If ActiveSheet.VPageBreaks.Count + 1 = 2 Then ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
xR(1, 5) = "TOTAL": xR.Resize(, 4).Merge: xR(1, 5).Resize(, 3).Merge: xR(1, 8) = V8: xR(1, 9) = V9: xR(1, 10) = Round(V10, 2): xR(1, 10).Resize(1, 5).Merge: xR.Rows.RowHeight = 27 * Sh
With xR.Resize(1, 14): .Font.Size = 12: .Font.Bold = True: End With
ActiveSheet.Names.Add Name:="PrintArea", RefersTo:=Range([A1], xR(, 14)): ActiveSheet.PageSetup.PrintArea = "PrintArea"
For i = 20 To xR.Row '800-327.3=472.7 : 472.7/327.3=1.44
   TT = Cells(i, 3) & "/" & Cells(i, 5)
   If TT = "/" Then GoTo i03
   If TT = SS Or SS = "" Then
      If xRc Is Nothing Then Set xRc = Cells(i, 3): Set xRe = Cells(i, 5) Else Set xRc = Union(xRc, Cells(i, 3)): Set xRe = Union(xRe, Cells(i, 5))
   End If
i03: RH = RH + Cells(i, 1).RowHeight
   If Cells(i + 1, 3) & "/" & Cells(i + 1, 5) <> TT Or RH / TH > Tts Then
      If Not xRc Is Nothing Then
         If xRc.Count > 1 Then With Intersect(xRc, xRc.Offset(1)): .Merge: .Value = "": End With: xRe.Merge: xRe.VerticalAlignment = xlTop: xRc.Offset(, 5).Merge
      End If
      Set xRc = Nothing: Set xRe = Nothing: SS = Cells(i + 1, 3) & "/" & Cells(i + 1, 5)
   End If
   If RH / TH > Tts Then Cells(i + 1, 1).PageBreak = xlPageBreakManual: RH = 0
Next
Intersect(Range("PrintArea"), Range("PrintArea").Offset(19)).Borders.LineStyle = 1
Set Z = Nothing: Erase PGNr, Rackr, Itemr, PGr: Set xR = Nothing: Set xRs = Nothing: Set xRc = Nothing: Set xRe = Nothing
End Sub