Andy2483

回復 20# 198188


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

198188

回復 21# Andy2483


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

Andy2483

回復 22# 198188


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

下載 (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

198188

回復 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

回復 24# 198188


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

198188

回復 25# Andy2483


    好的，謝謝。

Andy2483

回復 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

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

回復 28# Andy2483


    謝謝，前輩指點。

198188

下載 (44.89 KB)

2024-2-26 09:36

回復 28# Andy2483


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