Public xlPaperA2%Sub 填满页面排版()xlPaperA2 = 66 'A2编号66Dim ws As Worksheet: Set ws = ActiveSheetDim FirstCol As Long, LastCol As Long, LastRow As LongDim TargetRange As RangeDim UsablePageWidth As DoubleDim CurrentWidth As DoubleDim StartFontSize As Double, BestFontSize As DoubleDim TestSize As DoubleDim StepSize As Double: StepSize = 0.05 ' 精细步长Dim MaxFontSize As Double: MaxFontSize = 48Dim OriginalView As Long' ===== 1. 获取数据范围 =====On Error Resume NextWith wsLastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).ColumnFirstCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlNext).ColumnLastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).RowEnd WithOn Error GoTo 0If LastCol = 0 Then Exit SubIf FirstCol > LastCol Then Exit SubIf LastRow = 0 Then LastRow = 1Set TargetRange = ws.Range(ws.Cells(1, FirstCol), ws.Cells(LastRow, LastCol))' ===== 2. 保存并切换到普通视图（防死机）=====On Error Resume NextOriginalView = ws.Parent.Windows(1).Viewws.Parent.Windows(1).View = xlNormalViewOn Error GoTo 0Application.ScreenUpdating = FalseApplication.Calculation = xlCalculationManual' ===== 3. 安全获取当前字体大小 =====Dim Temp As VariantTemp = TargetRange.Font.SizeIf IsNull(Temp) Or Temp <= 0 Or Temp > 100 ThenStartFontSize = 10ElseStartFontSize = TempEnd If' ===== 4. 计算页面可用宽度（磅）=====UsablePageWidth = GetPageWidthInPoints(ws) - ws.PageSetup.LeftMargin - ws.PageSetup.RightMarginIf UsablePageWidth <= 0 Then UsablePageWidth = 400' ===== 5. 核心：递增逼近最大填充字体 =====BestFontSize = StartFontSize  ' 至少用原始字体TestSize = StartFontSizeDo While TestSize <= MaxFontSize' 设置字体TargetRange.Font.Size = TestSize' 重新 AutoFit 列宽TargetRange.EntireColumn.AutoFit' 获取当前总宽度CurrentWidth = TargetRange.Width' 检查是否超出页面If CurrentWidth > UsablePageWidth Then' 超了，退出（上一个 TestSize 是合法的最大值）Exit DoElse' 未超，记录为当前最佳BestFontSize = TestSizeEnd IfTestSize = TestSize + StepSizeLoop' ===== 6. 应用最佳字体 =====TargetRange.Font.Size = BestFontSizeTargetRange.EntireColumn.AutoFitCurrentWidth = TargetRange.Width  ' 最终宽度' ===== 7. 恢复视图 =====On Error Resume Nextws.Parent.Windows(1).View = OriginalViewApplication.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueOn Error GoTo 0' ===== 8. 显示结果 & 列宽补偿 =====Dim FillRatio As DoubleFillRatio = CurrentWidth / UsablePageWidth' ? 如果填充率太低，则用二分法拉宽If CurrentWidth < UsablePageWidth * 0.99 ThenDim TargetTotalWidth As DoubleTargetTotalWidth = UsablePageWidth * 0.995  ' 目标填满 99.5%' 调用二分法调整AdjustToTargetWidth_Binary TargetRange, TargetTotalWidth' 更新 CurrentWidth 用于后续判断CurrentWidth = TargetRange.WidthEnd IfMsgBox "排版完成！" & vbCrLf & _"最终字体：" & Format(BestFontSize, "0.1") & " pt" & vbCrLf & _"可用宽度：" & Format(UsablePageWidth, "0.1") & " 磅" & vbCrLf & _"实际宽度：" & Format(CurrentWidth, "0.1") & " 磅" & vbCrLf & _"填充比例：" & Format(FillRatio * 100, "0.1") & "%" & vbCrLf & _IIf(FillRatio >= 0.98, "? 几乎填满", "?? 接近填满"), vbInformationEnd Sub
' ===== 二分法调整整体列宽（容忍 0.5cm 误差，稳定退出）=====
' 输入：
'   TargetRange: 要调整的区域
'   TargetWidth: 目标总宽度（磅）
' 输出：列宽被等比放大，总宽度逼近目标
Sub AdjustToTargetWidth_Binary(TargetRange As Range, TargetWidth As Double)Dim Low As Double, High As Double, Mid As DoubleDim i As LongDim OriginalWidths() As DoubleDim CurrentTotalWidth As DoubleDim Tolerance As DoubleDim Iteration As LongDim ws As Worksheet: Set ws = TargetRange.Worksheet' ===== 参数设置 =====Tolerance = 14  ' ±0.5 cm ≈ 14 磅（28.35 pt/cm）Low = 0.8       ' 最小缩小到 80%High = 3        ' 最大放大到 300%Iteration = 0' ===== 保存原始列宽 =====ReDim OriginalWidths(1 To TargetRange.Columns.Count)On Error GoTo RestoreAndExitApplication.EnableEvents = FalseApplication.Calculation = xlCalculationManualApplication.ScreenUpdating = FalseFor i = 1 To TargetRange.Columns.CountOriginalWidths(i) = TargetRange.Columns(i).ColumnWidthNext i' ===== 二分法逼近 =====Do While Iteration < 50  ' 防止死循环Mid = (Low + High) / 2Iteration = Iteration + 1' 应用缩放For i = 1 To TargetRange.Columns.CountTargetRange.Columns(i).ColumnWidth = OriginalWidths(i) * MidNext i' 获取当前总宽度On Error Resume NextCurrentTotalWidth = TargetRange.WidthOn Error GoTo 0' 安全检查If CurrentTotalWidth <= 0 ThenCurrentTotalWidth = 1End If' ===== 判断是否满足精度 =====If Abs(CurrentTotalWidth - TargetWidth) <= Tolerance ThenExit DoEnd If' 调整区间If CurrentTotalWidth < TargetWidth ThenLow = MidElseHigh = MidEnd If' 区间足够小，退出If (High - Low) < 0.0001 ThenExit DoEnd IfLoop' ===== 输出结果 =====Debug.Print "? 二分法完成："Debug.Print "  迭代次数: " & IterationDebug.Print "  最终内容宽度: " & Format(CurrentTotalWidth, "0.0") & " 磅 ≈ " & Format(CurrentTotalWidth / 28.35, "0.1") & " cm"Debug.Print "  目标宽度: " & Format(TargetWidth, "0.0") & " 磅 ≈ " & Format(TargetWidth / 28.35, "0.1") & " cm"Debug.Print "  剩余误差: " & Format(Abs(CurrentTotalWidth - TargetWidth), "0.0") & " 磅 ≈ " & Format(Abs(CurrentTotalWidth - TargetWidth) / 28.35, "0.2") & " cm"RestoreAndExit:' 恢复设置Application.EnableEvents = TrueApplication.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueErr.Clear
End Sub
' ===== 工具函数：获取页面实际打印宽度（磅） =====
' 输入：Worksheet
' 输出：横向时返回长边，纵向时返回短边（已考虑方向）
' 特点：只认 PaperSize 数值，不依赖 xlPaperXXX 枚举
Function GetPageWidthInPoints(ws As Worksheet) As DoubleDim PaperSize As LongDim WidthCm As Double  ' 纸张宽度（纵向时的宽度）Dim HeightCm As Double ' 纸张高度（纵向时的高度）PaperSize = ws.PageSetup.PaperSize' ===== 统一用厘米定义纸张尺寸（纵向时） =====Select Case PaperSizeCase 66, 18   ' A2WidthCm = 42#HeightCm = 59.4Case 11        ' A3WidthCm = 29.7HeightCm = 42#Case 9         ' A4WidthCm = 21#HeightCm = 29.7Case 13        ' A5WidthCm = 14.8HeightCm = 21#Case 14        ' A6WidthCm = 10.5HeightCm = 14.8Case 12        ' B4WidthCm = 25#HeightCm = 35.3Case 15        ' B5WidthCm = 17.6HeightCm = 25#Case 1         ' LetterWidthCm = 21.59  ' 8.5 inHeightCm = 27.94 ' 11 inCase 4         ' LegalWidthCm = 21.59HeightCm = 35.56 ' 14 inCase 50        ' B5 (JIS)WidthCm = 18.2HeightCm = 25.7Case 51        ' A4 NarrowWidthCm = 21#HeightCm = 28.4Case Else' 默认：A4WidthCm = 21#HeightCm = 29.7End Select' ===== 根据方向决定返回哪个维度 =====On Error Resume NextIf ws.PageSetup.Orientation = xlLandscape Then' 横向：页面宽度 = 纸张高度（长边）GetPageWidthInPoints = Application.CentimetersToPoints(HeightCm)Else' 纵向：页面宽度 = 纸张宽度（短边）GetPageWidthInPoints = Application.CentimetersToPoints(WidthCm)End If' ===== 安全兜底 =====If Err.Number <> 0 Or GetPageWidthInPoints <= 0 ThenGetPageWidthInPoints = Application.CentimetersToPoints(21) ' A4 宽Err.ClearEnd IfOn Error GoTo 0
End Function'' ===== 辅助函数：根据 PaperSize 数值返回纸张高度（英寸）=====
'' 说明：直接使用数字，不依赖 xlPaperXXX 枚举，避免未定义问题
'Function GetPageHeightInInches(PaperSize As Long) As Double
'    Select Case PaperSize
'        Case 66, 18  ' A2: 42.0 cm × 59.4 cm → 高度 59.4 cm = 23.39 英寸
'            GetPageHeightInInches = 23.39   ' 59.4 cm
'        Case 11       ' A3: 29.7 × 42.0 cm → 高度 42.0 cm
'            GetPageHeightInInches = 16.54   ' 42.0 cm
'        Case 9        ' A4: 21.0 × 29.7 cm → 高度 29.7 cm
'            GetPageHeightInInches = 11.69   ' 29.7 cm
'        Case 13       ' A5: 14.8 × 21.0 cm
'            GetPageHeightInInches = 8.27    ' 21.0 cm
'        Case 14       ' A6: 10.5 × 14.8 cm
'            GetPageHeightInInches = 5.83    ' 14.8 cm
'        Case 12       ' B4: 25.0 × 35.3 cm
'            GetPageHeightInInches = 13.89   ' 35.3 cm
'        Case 15       ' B5: 17.6 × 25.0 cm
'            GetPageHeightInInches = 9.84    ' 25.0 cm
'        Case 1        ' Letter: 8.5 × 11 in
'            GetPageHeightInInches = 11
'        Case 4        ' Legal: 8.5 × 14 in
'            GetPageHeightInInches = 14
'        Case 50       ' B5 (JIS): 常见打印机选项
'            GetPageHeightInInches = 9.84
'        Case 51       ' A4 小（窄）: 21.0 × 28.4 cm
'            GetPageHeightInInches = 11.18
'        Case Else
'            ' 默认返回 A4 高度
'            GetPageHeightInInches = 11.69
'    End Select
'End Function
Sub 检查页面参数()Dim ws As Worksheet: Set ws = ActiveSheetDim FirstCol As Long, LastCol As Long, LastRow As LongDim TargetRange As RangeDim UsablePageWidth As DoubleDim ContentWidth As DoubleDim LeftMarginPt As Double, RightMarginPt As DoubleDim PagePrintableStartX As Double  ' 可打印区域起始X（距左边）Dim ContentEndX As Double         ' 内容结束位置（距左边）Dim PagePrintableEndX As Double   ' 可打印区域结束位置（距左边）Dim RightGap As Double            ' 右侧剩余空白（磅）Dim RightGapCm As Double          ' 右侧剩余空白（厘米）Dim TEM_S As StringWith ws.PageSetupTEM_S = TEM_S & vbCrLf & "=== 页面设置参数 ==="TEM_S = TEM_S & vbCrLf & "纸张大小代码:" & .PaperSizeTEM_S = TEM_S & vbCrLf & "方向:" & IIf(.Orientation = xlPortrait, "纵向", "横向")LeftMarginPt = .LeftMarginRightMarginPt = .RightMarginTEM_S = TEM_S & vbCrLf & "左页边距:" & LeftMarginPt & "磅 ≈" & Format(LeftMarginPt / 28.35, "0.0") & "cm"TEM_S = TEM_S & vbCrLf & "右页边距:" & RightMarginPt & "磅 ≈" & Format(RightMarginPt / 28.35, "0.0") & "cm"End With' ===== 计算页面总宽度（打印区域宽度）=====Dim PageTotalPrintableWidth As DoublePageTotalPrintableWidth = GetPageWidthInPoints(ws) - LeftMarginPt - RightMarginPtTEM_S = TEM_S & vbCrLf & "页面可用宽度（计算）:" & PageTotalPrintableWidth & "磅"TEM_S = TEM_S & vbCrLf & "页面可用宽度（厘米）:" & Format(PageTotalPrintableWidth / 28.35, "0.1") & "cm"' ===== 获取内容范围 =====On Error Resume NextWith wsLastCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).ColumnFirstCol = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlNext).ColumnLastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).RowEnd WithOn Error GoTo 0If LastCol = 0 Or FirstCol > LastCol Or LastRow = 0 ThenTEM_S = TEM_S & "?? 未找到数据"Exit SubEnd IfSet TargetRange = ws.Range(ws.Cells(1, FirstCol), ws.Cells(LastRow, LastCol))ContentWidth = TargetRange.WidthTEM_S = TEM_S & vbCrLf & "内容实际宽度:" & ContentWidth & "磅 ≈" & Format(ContentWidth / 28.35, "0.1") & "cm"' ===== 计算右侧剩余边距 =====' 可打印区域起始 X 坐标（从页面左边开始）PagePrintableStartX = LeftMarginPt' 可打印区域结束 X 坐标PagePrintableEndX = LeftMarginPt + PageTotalPrintableWidth' 内容结束位置（从页面左边开始）ContentEndX = LeftMarginPt + ContentWidth' 右侧剩余空白RightGap = PagePrintableEndX - ContentEndXRightGapCm = RightGap / 28.35TEM_S = TEM_S & vbCrLf & "右侧剩余边距:" & RightGap & "磅 ≈" & Format(RightGapCm, "0.1") & "cm"If RightGapCm > 0 ThenTEM_S = TEM_S & vbCrLf & "? 右边还能再挤进" & Format(RightGapCm, "0.1") & "cm"ElseTEM_S = TEM_S & "? 内容已超出可用区域！" & Format(RightGapCm, "0.1") & "cm"End IfT_CHECK_PAGES.Text = TEM_S
End Sub' ===== 按钮事件 =====
Private Sub CMD_AUTO_COL_WIDTH_Click()填满页面排版
End SubPrivate Sub cmd_checkpage_Click()检查页面参数
End Sub