麻辣家族討論版版 - Powered by Discuz! Board

標題: 讀取及歸類及框綫格式 [打印本頁]

作者: 198188 時間: 2024-2-6 11:19 標題: 讀取及歸類及框綫格式

附件是一個多工作頁的互相抽取資料的模式，讀取后牽涉一些框綫，空格格式等問題，請各大大幫忙看看有沒有方法解決，謝謝。

作者: 198188 時間: 2024-2-7 10:20

附件是一個多工作頁的互相抽取資料的模式，讀取后牽涉一些框綫，空格格式等問題，請各大大幫忙看看有 ...
198188 發表於 2024-2-6 11:19

附上拆分清單格式構思，希望能夠給各位大大更加容易理解。

作者: Andy2483 時間: 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

祝各位前輩新春愉快

作者: mark15jill 時間: 2024-2-7 15:57

附上拆分清單格式構思，希望能夠給各位大大更加容易理解。
198188 發表於 2024-2-7 10:20

同篇問題建議用修改或是回覆.. 不然很亂

作者: 198188 時間: 2024-2-7 16:43

回復 3# Andy2483

謝謝您的解答，試過結果后，有附件注釋，方便清晰規則。
另外可否在VBA加上注釋，方便學習，謝謝。

作者: 198188 時間: 2024-2-8 08:50

回復 4# mark15jill

謝謝大大提醒。:lol

作者: Andy2483 時間: 2024-2-19 11:58

回復 5# 198188

先看看執行後是否為需求的列印分頁,再看看後續如何解
[attach]37447[/attach]

作者: 198188 時間: 2024-2-19 15:01

回復 7# Andy2483

附上“VBA打印格式”，這是根據您的VBA 做出來的效果，另一個附件“正確格式”是我想要的效果。
根據效果，好像雙數的只能顯示一行。

作者: Andy2483 時間: 2024-2-19 15:15

本帖最後由 Andy2483 於 2024-2-19 15:27 編輯

回復 8# 198188

這樣回復無法確認分頁是否正確,如果再調整過欄寬或比例就得重算參數
以下附件是7#檔案匯出PDF檔的結果,與8#回復雞同鴨講
[attach]37453[/attach]

以下是後學分頁預覽的狀況:
[attach]37454[/attach]

作者: 198188 時間: 2024-2-19 15:58

回復 9# Andy2483

我打印PDF 總是把最後一行推到第二頁，這個可能是大家打印的邊界不一樣吧。

另外在相同的SR裏面和在打印時同一頁，
欄 C 及欄E 如果相同，只要第一行有文字，
欄 C 第一行有框綫，之後的所有相同的，只要四邊有框綫
欄 E 所有相同的，只要四邊有框綫
欄H,I,J,K,L,M,N 四邊有框綫
（之前好像可以，現在變成沒有這個功能了）

作者: Andy2483 時間: 2024-2-19 16:15

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

回復 10# 198188

7#的範例只是想先確認分頁是否正確,如果分頁符合需求再處理框線及補第一列空白格問題
列印跟EXCEL版本及其它參數有關

作者: 198188 時間: 2024-2-19 16:39

回復 9# Andy2483

這個分頁正確

作者: Andy2483 時間: 2024-2-19 16:45

回復 10# 198188

看看還會不會 "後一行推到第二頁"...等問題,如果分頁正確再繼續
[attach]37455[/attach]

作者: 198188 時間: 2024-2-19 16:51

[attach]37456[/attach][attach]37456[/attach]回復 13# Andy2483

還是一樣。我截圖了一下邊界設定圖片讓你看看大家的設置不一樣。

作者: Andy2483 時間: 2024-2-19 17:46

回復 14# 198188

看這截圖畫面好像是您測試的檔不一樣，並不是用後學上傳的檔案
與其亂猜不如請上傳實際要測試的檔案

作者: 198188 時間: 2024-2-19 18:07

回復 15# Andy2483

是同一個Excel，不過解壓后，無法運行VBA, 需要更名后才能運行。
[attach]37458[/attach]

作者: Andy2483 時間: 2024-2-19 18:53

回復 16# 198188

現在沒有PC可以測試，前輩可以調整程式最後有個1.35的參數把它試改為1.3 或 1.25再執行看看

作者: 198188 時間: 2024-2-20 08:17

回復 17# Andy2483

改爲1.3后，測試沒有問題了

作者: Andy2483 時間: 2024-2-20 14:21

回復 18# 198188

謝謝論壇,謝謝前輩回復
後學藉此帖學習到很多知識,學習的方案如下,請前輩參考
[attach]37459[/attach]

作者: 198188 時間: 2024-2-20 17:19

回復 19# Andy2483

出現之前的問題，最後一行變成第二頁，内容有亂碼，不知道怎樣改。
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$, 夹肈籔戈ゑㄒ#
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
夹肈籔戈ゑㄒ = [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 > 夹肈籔戈ゑㄒ 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 > 夹肈籔戈ゑㄒ 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

作者: Andy2483 時間: 2024-2-20 17:44

回復 20# 198188

儲存格O1的1.35 改為1.3 試試看
我忘記了簡體版會亂碼，不影響執行就沒關系

作者: 198188 時間: 2024-2-20 18:29

回復 21# Andy2483

在哪個位置，因爲亂碼，我分辦不出。

作者: Andy2483 時間: 2024-2-20 18:47

本帖最後由 Andy2483 於 2024-2-21 07:07 編輯

回復 22# 198188

儲存格O1
在表格的O1上是1.35改為 1.3 試試看
[attach]37460[/attach]

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

作者: 198188 時間: 2024-2-21 14:58

回復 23# Andy2483

可以了，謝謝。

另外有個問題，我用錄製方式寫了一個VBA 是在附件裏建立兩個樞紐分析表。不過運行的時候在下面這個位置卡住了。 ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
      "sheet1!R1C1:R1048576C12", Version:=8).CreatePivotTable TableDestination:= _
      "sheet1!R1C26", TableName:="PivotTable21", DefaultVersion:=8
請幫我看看是哪裏出現問題。
另外能不能幫忙改良一下，
1) 欄Z -AA的樞紐分析表
資料來源從A1  - L1  :  A (欄B最後一行） -  L(欄B最後一行）
欄位清單：
列： SECTION & LENGTH
值：加總QTY

2) 欄AC-AD的樞紐分析表
資料來源從N1  - V1  :  N (欄P最後一行） -  V(欄P最後一行）
欄位清單：
列： SECTION & LENGTH
值：加總Q'TY

Sub Macro2()
  Application.CutCopyMode = False
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
      "sheet1!R1C1:R1048576C12", Version:=8).CreatePivotTable TableDestination:= _
      "sheet1!R1C26", TableName:="PivotTable21", DefaultVersion:=8
Sheets("sheet1)").Select
Cells(1, 26).Select
With ActiveSheet.PivotTables("PivotTable21")
      .ColumnGrand = True
      .HasAutoFormat = True
      .DisplayErrorString = False
      .DisplayNullString = True
      .EnableDrilldown = True
      .ErrorString = ""
      .MergeLabels = False
      .NullString = ""
      .PageFieldOrder = 2
      .PageFieldWrapCount = 0
      .PreserveFormatting = True
      .RowGrand = True
      .SaveData = True
      .PrintTitles = False
      .RepeatItemsOnEachPrintedPage = True
      .TotalsAnnotation = False
      .CompactRowIndent = 1
      .InGridDropZones = False
      .DisplayFieldCaptions = True
      .DisplayMemberPropertyTooltips = False
      .DisplayContextTooltips = True
      .ShowDrillIndicators = True
      .PrintDrillIndicators = False
      .AllowMultipleFilters = False
      .SortUsingCustomLists = True
      .FieldListSortAscending = False
      .ShowValuesRow = False
      .CalculatedMembersInFilters = False
      .RowAxisLayout xlCompactRow
End With
With ActiveSheet.PivotTables("PivotTable21").PivotCache
      .RefreshOnFileOpen = False
      .MissingItemsLimit = xlMissingItemsDefault
End With
ActiveSheet.PivotTables("PivotTable21").RepeatAllLabels xlRepeatLabels
ActiveWorkbook.ShowPivotTableFieldList = True
With ActiveSheet.PivotTables("PivotTable21").PivotFields("SECTION")
      .Orientation = xlRowField
      .Position = 1
End With
With ActiveSheet.PivotTables("PivotTable21").PivotFields("LENGTH")
      .Orientation = xlRowField
      .Position = 2
End With
ActiveSheet.PivotTables("PivotTable21").AddDataField ActiveSheet.PivotTables( _
      "PivotTable21").PivotFields("QTY"), "Count of QTY", xlCount
With ActiveSheet.PivotTables("PivotTable21").PivotFields("Count of QTY")
      .Caption = "Sum of QTY"
      .Function = xlSum
End With
ActiveWorkbook.ShowPivotTableFieldList = False
End Sub

作者: Andy2483 時間: 2024-2-21 15:14

回復 24# 198188

謝謝前輩回復
至於新提出的樞紐問題需求與此主題差異大,建議前輩再琢磨一下,如果還沒法解決另發新話題給版上前輩一起做交流

作者: 198188 時間: 2024-2-21 15:34

回復 25# Andy2483

好的，謝謝。

作者: Andy2483 時間: 2024-2-22 13:04

本帖最後由 Andy2483 於 2024-2-22 13:06 編輯

回復 24# 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&, SS$, Tts#
Dim PGNr, Rackr, Itemr, PGr, DPLs As Worksheet, xR As Range, xRs As Range, TT$, TH#, RH, Sh#, xRc As Range, xRe As Range
'↑宣告變數,%是短整數,&是長整數,$是字串變數,#是雙精度小數,As Range是儲存格變數,As Worksheet是工作表變數,其它沒有指定的是通用型變數
Set Z = CreateObject("Scripting.Dictionary"): Application.ScreenUpdating = False: Application.DisplayAlerts = False: Sh = Rows(17).RowHeight / 32
'↑令Z變數是字典:令螢幕暫不隨程序做變化:令程序不要跳出(合併儲存格只留左上格內容)的詢問窗,令Sh變數是第17列列高/32 值
Tts = [O1]: PGNr = [PGN!A1].CurrentRegion: Rackr = [Rack!A1].CurrentRegion: Itemr = [Item!A1].CurrentRegion: PGr = [PG!A1].CurrentRegion
'↑令Tts變數是[O1]儲存格值,令PGNr變數是工作表("PGN").[A1]儲存格相鄰串聯後擴展成的最小方正區域儲存格值帶入的二維陣列,Rackr/Itemr/PGr變數依此類推
Set DPLs = Sheets("DPL"): DPLs.Activate: T = [J3]: DPLs.UsedRange.Offset(19).EntireRow.Delete: Set xR = [A20]
'↑令DPLs變數是工作表("DPL"),令DPLs激活,令T這字串變數是[J3]儲存格值(Invoice No),令表頭以下的資料列整列刪除,令xR這儲存格變數是 [A20]儲存格
Cells.VerticalAlignment = xlCenter: ActiveSheet.ResetAllPageBreaks: [A1].Activate: For i = 1 To 19: TH = TH + Rows(i).RowHeight: Next
'↑令全部儲存格格式垂直向文字置中,令清除分頁線,令游標跳到[A1],設順迴圈將1到19列的列高相加給 TH變數
For i = 2 To UBound(PGr)
'↑設順迴圈!令i從2 到PGr陣列最大索引列號
If Z(PGr(i, 1) & "^") = "" Then Z(PGr(i, 1) & "^") = PGr(i, 2) Else MsgBox "PG表 " & PGr(i, 1) & " 重複": Exit Sub
'↑如果i迴圈列1欄PGr陣列值連接"^"符號所組成的新字串查Z字典回傳item是空字元!就令其item值是 i迴圈列2欄PGr陣列值,
'否則代表PG表的對照資料有重複, 跳出提示窗~~,最後結束程式執行
Next
For i = 2 To UBound(Rackr)
'↑設順迴圈!令i從2 到Rackr陣列最大所引列號
If Rackr(i, 11) <> T Then GoTo i01
'↑如果i迴圈列11欄Rackr陣列值不同於T變數(Invoice No),就跳到標示i01位置繼續執行
T14 = Rackr(i, 14): T5 = Rackr(i, 5): T15 = Rackr(i, 15)
'↑令T14這字串變數是i迴圈列14欄Rackr陣列值,T5/T15依此規則類推
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) = ""
'↑如果Z字典裡沒有T15變數key!就令R變數值是(N變數除3的餘數+1),令N變數累加1,令T15變數寫入Brr陣列中,令T15在Z字典對應item是空字元
If InStr("," & Z(T14 & "/GD") & ",", "," & T15 & ",") = 0 Then Z(T14 & "/GD") = Z(T14 & "/GD") & "," & T15
'↑如果T14變數連接"/GD"字串所組成新字串key查Z字典得item值再頭尾連接逗號所組成的新字串裡沒有 T15變數頭尾連接逗號所組成的新字串!
'就令該item字串以逗號連接T15變數後,放回Z字典中
If InStr("," & Z(T14 & "/RN") & ",", "," & T5 & ",") = 0 Then Z(T14 & "/RN") = Z(T14 & "/RN") & "," & T5: Z(T5 & "|") = i Else MsgBox "Rack表 " & T5 & " 重複": Exit Sub
'↑如果T14變數連接"/RN"字串所組成新字串key查Z字典得item值再頭尾連接逗號所組成的新字串裡沒有 T5變數頭尾連接逗號所組成的新字串!
'就令該item字串以逗號連接T5變數後,放回Z字典中,令T5變數連接"|"符號所組成的新字串當key,item是列號,納入Z字典中,
'否則代表Rack工作表第5欄裡的Rack Number有重複,令跳出提視窗~~~,,最後結束程式執行
i01: Next
DPLs.[G12].Resize(3, 4) = Brr: DPLs.[G15] = "TOTAL " & N & " X 45'HC CONTAINER": N = 0
'↑令DPLs變數[G12]儲存格擴展向下3列,向右擴展4欄範圍的儲存格值以Brr陣列值寫入
For i = 2 To UBound(PGNr)
'↑設順迴圈!令i從2 到PGNr陣列縱向最大索引列號
If PGNr(i, 1) <> T Then GoTo i02
'↑如果i迴圈列1欄PNGr陣列值不同於T變數(Invoice No),就跳到標示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)
'↑如果i迴圈列2欄PNGr陣列值連接"/GD"字串所組成的新字串在Z字典裡有此key!就令item換為新組合成的字串
i02: Next
For i = 2 To UBound(Itemr)
'↑設順迴圈!令i從2 到Itemr陣列縱向最大索引列號
If Z.Exists(Itemr(i, 3) & "|") Then Z(Itemr(i, 3) & "|") = Z(Itemr(i, 3) & "|") & "," & i
'↑如果以i迴圈列3欄Itemr陣列值連接"|"符號所組成的新字串查Z字典有此key!就令item以逗號連接i變數(列號)組成新字串放回Z字典中
Next

作者: Andy2483 時間: 2024-2-22 13:04

For Each A In Z.KEYS
'↑設逐項迴圈!令A變數是Z字典中的key
If Right(A, 3) <> "/RN" Then GoTo A01 Else Q = Split(Z(A), ","): xR = Z(Split(A, "/RN")(0) & "/GD")
'↑如果A變數右3字不是"/RN"字串!就令程序跳到標示A01位置繼續執行,
'否則就令Q變數是以逗號分割字串(以A變數查Z字典回傳的字串)所形成的一維陣列,令xR儲存格值是查Z字典回傳值
With xR.Resize(, 14): .Merge: .Font.Size = 9: .Font.Bold = True: .Rows.RowHeight = 52 * Sh: End With
'↑令CONTAINER NO標題格合併,文字大小9,設文字粗體,列高52個單位
For i = 1 To UBound(Q)
'↑設順迴圈!令i從1 到Q陣列最大索引號
   Set xR = xR(2): xR.Resize(1, 14).Interior.ColorIndex = 15: xR.Resize(1, 14).Font.Bold = True: xR.Rows.RowHeight = 27 * Sh
   '↑令xR儲存格變為下一格,令從xR儲存格右擴展14格範圍儲存格底色為灰色/文字為粗體,列高27個單位
   With xR.Resize(1, 4): .Merge: .Font.Size = 12:  .Value = "'" & Q(i): End With
   '↑令從xR儲存格右擴展14格範圍儲存格合並/文字大小12/令文字內容為i迴圈Q陣列值(前面加單引號是令強制其為文字)
   xR(1, 6).Resize(, 2).Merge: xR(1, 10).Resize(, 5).Merge
   '↑令段落儲存格合併
   P = Split(Z(Q(i) & "|"), ","): R = Val(P(0))
   '↑令P變數是以逗號分割字典裡記錄的Item表列號串,令R變數是Rack表的列號
   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)
   '↑令自xR儲存格右8格(H)儲存格值是R變數列6欄Rackr陣列值,令自xR儲存格右9格(I)儲存格值是R變數列9欄Rackr陣列值,
   '令自xR儲存格右10格(H)儲存格值是R變數列8/9/10欄Rackr陣列值以"x"符號連接所組成的新字串
   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, 1)
   '↑令V8變數累加自xR儲存格右8格(H)儲存格值,令V9變數累加自xR儲存格右9格(H)儲存格值,令V10變數是長*寬*高值,令xRs變數是xR儲存格的下一格儲存格
   For j = 1 To UBound(P)
   '↑設順迴圈!令j變數從1 到P陣列最大索引號
      Tp1 = Itemr(P(j), 5): Tp3 = Z(Itemr(P(j), 6) & "^"): Tp5 = Itemr(P(j), 4)
      '↑令Tp1是 Item表Item Number值,令Tp3是以 Item表Item Description Group值對照GP表得到的 Description
      Y = Z(Q(i) & "/" & Tp1 & "/" & Tp3 & "/" & Tp5)
      '↑令Y變數是 5個關鍵字串以"/"符號連接起來的字串查Z字典回傳值
      If Y = 0 Then
      '↑如果Y變數是 0
         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))
         '↑令xR儲存格變更為下一格儲存格,令從xR儲存格右擴展14格範圍儲存格文字大小9,令xR儲存格值是 Tp1變數值,令xR儲存格右3格值是 Tp3變數值,
         '令xR儲存右5格值是 Tp5變數值,令xR儲存右6格值是 Item表的 Quantity值
         Z(Q(i) & "/" & Tp1 & "/" & Tp3 & "/" & Tp5) = xR.Row: xR.Rows.RowHeight = 27 * Sh: GoTo j01
         '↑令Y變數是 5個關鍵字串以"/"符號連接起來的字串當key,item是xR儲存格列號,令xR儲存格當列列高是27個單位,令跳到標示j01位置繼續執行
      End If
      Cells(Y, 6) = Cells(Y, 6) + Val(Itemr(P(j), 7))
      '↑令Y變數列F欄儲存格值累加 Item表的 Quantity值
j01:  Next
   With Range(xRs, xR(1, 14))
   '↑以下是關於xRs儲存格至 xR儲存格右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
      '↑設順迴圈!令R變數從1 到該區域的列數,令各區段儲存格合併
   End With
Next
Set xR = xR(2)
'↑令xR儲存格變更為下一格儲存格
A01: Next
Cells.VerticalAlignment = xlCenter: If ActiveSheet.VPageBreaks.Count + 1 = 2 Then ActiveSheet.VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
'↑令全部儲存格格式垂直方向文字置中,'↑如果列印範圍的橫向頁數是2! 就令縱向分頁線移至最右側,讓橫向頁數是1,自動調整其他配合列印參數
https://forum.twbts.com/viewthread.php?tid=19505
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
'↑令xR儲存格右5格儲存格值是 "TOTAL" 字串,前4格範圍合併儲存格,右5格開始擴展右3格範圍合併儲存格,令填入統計值並且合併儲存格,令列高是27個單位
With xR.Resize(1, 14): .Font.Size = 12: .Font.Bold = True: End With
'↑令xR儲存格擴展右14格範圍文字大小為12 / 粗體
ActiveSheet.Names.Add Name:="PrintArea", RefersTo:=Range([A1], xR(, 14)): ActiveSheet.PageSetup.PrintArea = "PrintArea"
'↑令儲存格範圍建立名稱為 "PrintArea",令列印範圍為名稱 "PrintArea"
For i = 20 To xR.Row '800-327.3=472.7 : 472.7/327.3=1.44
'↑設順迴圈令i變數從20到 xR儲存格列號
TT = Cells(i, 3) & "/" & Cells(i, 5)
'↑令TT變數是i迴圈列C欄值與i迴圈列E欄值以"/"符號連接組成的新字串
If TT = "/" Then GoTo i03
'↑如果TT變數是 "/"符號!就令程序跳到標示i03位置繼續執行
If TT = SS Or SS = "" Then
'↑如果TT變數同SS變數或SS變數是空字元??
   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))
   '↑如果xRc儲存格是空的!就令xRc儲存格是i迴圈列C欄儲存格,令xRe儲存格是i迴圈列E欄儲存格,
   '否則就令i迴圈列C欄儲存格納入xRc儲存格集之中,令i迴圈列E欄儲存格納入xRe儲存格集之中
End If
i03: RH = RH + Cells(i, 1).RowHeight
   '↑令RH變數累加迴圈列高
If Cells(i + 1, 3) & "/" & Cells(i + 1, 5) <> TT Or RH / TH > Tts Then
'↑如果(i+1)迴圈列C欄值與(i+1)迴圈列E欄值以"/"符號連接組成的新字串不同於 TT變數或 RH變數除以TH變數的商 > Tts變數??
   If Not xRc Is Nothing Then
   '↑如果xRc儲存格有物件??
      If xRc.Count > 1 Then With Intersect(xRc, xRc.Offset(1)): .Merge: .Value = "": End With: xRe.Merge: xRe.VerticalAlignment = xlTop: xRc.Offset(, 5).Merge
      '↑如果xRc儲存格數大於1!就令xRc儲存格集區域第1列(不含)以下的儲存格做合併,令xRe儲存格集做合併,文字偏上
   End If
   Set xRc = Nothing: Set xRe = Nothing: SS = Cells(i + 1, 3) & "/" & Cells(i + 1, 5)
   '↑令xRc xRe變數清空,令SS變數是 (i+1)迴圈列C欄值與(i+1)迴圈列E欄值以"/"符號連接組成的新字串
End If
If RH / TH > Tts Then Cells(i + 1, 1).PageBreak = xlPageBreakManual: RH = 0
'↑如果RH / TH商大於 Tts!就令在i+1列設定分頁線,令RH變數歸零
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

作者: 198188 時間: 2024-2-22 13:53

回復 28# Andy2483

謝謝，前輩指點。

作者: 198188 時間: 2024-2-26 09:37

本帖最後由 198188 於 2024-2-26 09:38 編輯

[attach]37491[/attach]回復 28# Andy2483

我今天試了一個新的，出現紅色部分的問題。
左邊黑色字的是VBA執行出來的，右邊的是想要的結果。

作者: Andy2483 時間: 2024-2-26 11:07

回復 30# 198188

謝謝前輩回復
增加檢查"PGN"表資料是否有 Invoice No,執行結果
[attach]37492[/attach]

For i = 2 To UBound(PGNr)
Z(PGNr(i, 1)) = "/" '20240226新增
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)
End If
i02: Next
If Z(T) <> "/" Then MsgBox "PGN表沒有 " & T & " 項目": Exit Sub '20240226新增
For i = 2 To UBound(Itemr)
If Z.Exists(Itemr(i, 3) & "|") Then Z(Itemr(i, 3) & "|") = Z(Itemr(i, 3) & "|") & "," & i
Next

作者: 198188 時間: 2024-2-26 11:34

回復 31# Andy2483

加在哪個位置？最後嗎？

作者: 198188 時間: 2024-2-26 14:09

回復 31# Andy2483
之前上載錯了附件，這個附件是運行后處理的效果。

作者: Andy2483 時間: 2024-2-26 14:17

回復 33# 198188

PGN表裡就是沒有 C864-2024 這資料,不知所云

作者: 198188 時間: 2024-2-26 14:27

回復 34# Andy2483

不好意思，加了，左上角問題不存在，右下方TOTAL那個地方的問題還是存在。

作者: Andy2483 時間: 2024-2-26 15:07

回復 30# 198188

宣告裡的 V8&, V9& 改為 V8#, V9#

作者: 198188 時間: 2024-2-26 15:20

回復 36# Andy2483

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#
修改了，還有紅色字兩處問題。
[attach]37503[/attach]

作者: Andy2483 時間: 2024-2-26 15:36

回復 37# 198188

H欄整欄選取右鍵 >儲存格格式:
[attach]37504[/attach]

至於合計10,請自己試試,27#有註解,一起學習

作者: 198188 時間: 2024-2-26 18:03

回復 38# Andy2483

合計10解決了，不過889就算在外面儲存格調校了格式，但是運行VBA后，還是一樣變成整數。

Sub TEST()
Dim Brr(1 To 100, 1 To 14), W, A, Z, Q, P, i&, j%, R&, C%, N&, x%, T$, T14$, T15$, T5$, V6#, 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) & "REPEAT": 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 Sheet" & T5 & "REPEAT": 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): W = W + Itemr(P(j), 7)
      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(1, 6) = W: xR.Resize(, 4).Merge: xR(1, 6).Resize(, 2).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

作者: Andy2483 時間: 2024-2-27 08:34

回復 39# 198188

厲害,以下紅字也要加,另外我的H欄整欄(連同後方的空格)選取變更格式為小數兩位後,執行就會帶小數889.00,請再試試
For j = 1 To UBound(P)
      Tp1 = Itemr(P(j), 5): Tp3 = Z(Itemr(P(j), 6) & "^"): Tp5 = Itemr(P(j), 4): W = W + Itemr(P(j), 7)
      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)): W = W + Itemr(P(j), 7)
j01:  Next

作者: 198188 時間: 2024-2-27 09:33

回復 40# Andy2483

可以了，謝謝前輩指點。
請問如果只是想讓某個儲存格，顯示多少個小數位，VBA怎樣表達?

作者: Andy2483 時間: 2024-2-27 09:40

回復 41# 198188

錄製巨集試試看,很多代碼都可以錄製後再簡化就可以用了

作者: 198188 時間: 2024-2-27 09:46

回復 42# Andy2483

RANGE("A1").NumberFormatLocal = "0.00"
這樣嗎？

作者: 198188 時間: 2026-2-3 16:39

回復 198188

儲存格O1
在表格的O1上是1.35改為 1.3 試試看

Option Explicit
Sub TEST()
...
Andy2483 發表於 2024-2-20 18:47

With xR.Resize(, 14): .Merge: .Font.Size = 9: .Font.Bold = True: .Rows.RowHeight = 52: End With

前輩這個列高能否自動調整？

我修改成這句，列高太多，在頂部多了很多空白
With xR.Resize(, 14): .Rows.AutoFit.：Merge: .Font.Size = 9: .Font.Bold = True: End With
[attach]38358[/attach]

我修改成這句，就沒有改變列高
With xR.Resize(, 14): Merge:.Rows.AutoFit.： .Font.Size = 9: .Font.Bold = True: End With
[attach]38359[/attach]

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