如何将两区域Union打印范围适配为1页宽？排查分页异常

需要将工作表中B-E列与G-H列的联合区域适配为1页宽（纵向可超过1页），但即便缩小字号和列宽，G-H列区域始终被分到第二页。

工作表布局 #

• 列标题位于第5行
• B、C、D、E列：存储其他工作表的数据汇总，行数不固定（可能多于/少于20行）
• F列：隐藏列，用于存储计算总计的临时内容，打印时需省略
• G列：通过COUNTIF函数计算的总计数据，仅H6-H20范围内有内容
• H列：对应G列总计的文本标签
• 第1行单元格作为宏触发按钮，执行打印、邮件发送、删除操作

问题原因 #

1. 非连续区域的打印逻辑限制：Excel处理非连续列的联合打印区域时，会将每个列组视为独立排版块，即便F列已隐藏，打印引擎仍可能保留原列的宽度占位，导致两个列组的总宽度超出单页范围。
2. 区域范围不匹配：代码中设置的打印区域起始行是第3行，但实际标题行在第5行，多余的空白行会干扰打印布局的自动适配逻辑。
3. 打印设置生效时机错误：Application.PrintCommunication = False放在With块内部，导致部分PageSetup参数未被正确应用。

解决办法 #

方案1：优化现有联合区域的打印设置 #

• 调整打印区域起始行与标题行对齐，减少空白行干扰
• 确保F列彻底隐藏，避免打印引擎计算其宽度
• 修正PrintCommunication的设置位置，确保所有打印参数生效

方案2：使用临时工作表打印（更稳定） #

将非连续区域复制到新的临时工作表，转为连续列后再打印，彻底规避非连续区域的排版问题。

修改后的代码（方案1优化版） #

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  
Application.Calculate
If Not Intersect(Target, Range("D1")) Is Nothing Then
    Me.Delete
ElseIf Not Intersect(Target, Range("A1")) Is Nothing Then
    GoToLast
ElseIf Not Intersect(Target, Range("B1")) Is Nothing Then

Dim lRow As Long
Dim dRow As Long
dRow = 20
lRow = Range("B" & Rows.Count).End(xlUp).Row

Dim MyRange1 As Range, MyRange2 As Range, BigRange As Range

' 调整起始行至标题行（第5行），匹配实际数据范围
If lRow > dRow Then
    Set MyRange1 = Range("B5:E" & lRow)
    Set MyRange2 = Range("G5:H" & lRow)
Else
    Set MyRange1 = Range("B5:E" & dRow)
    Set MyRange2 = Range("G5:H" & dRow)
End If

Set BigRange = Application.Union(MyRange1, MyRange2)

' 确保F列处于隐藏状态
Columns("F:F").Hidden = True

Application.PrintCommunication = False ' 先关闭通信提升设置效率
With BigRange.Parent.PageSetup
    .PrintArea = BigRange.Address
    .Zoom = False
    .FitToPagesTall = False
    .FitToPagesWide = 1
    .PrintTitleRows = "$5:$5" ' 设置每页打印标题行
End With
Application.PrintCommunication = True ' 恢复通信使设置生效

Application.CommandBars.ExecuteMso ("PrintPreviewAndPrint")
    
ElseIf Not Intersect(Target, Range("C1")) Is Nothing Then
    'EmailSheet
    Mail_Selection_Range_Outlook_Body
End If
End Sub

修改后的代码（方案2：临时工作表版） #

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  
Application.Calculate
If Not Intersect(Target, Range("D1")) Is Nothing Then
    Me.Delete
ElseIf Not Intersect(Target, Range("A1")) Is Nothing Then
    GoToLast
ElseIf Not Intersect(Target, Range("B1")) Is Nothing Then

Dim lRow As Long, dRow As Long
dRow = 20
lRow = Range("B" & Rows.Count).End(xlUp).Row
Dim tempWs As Worksheet
Dim sourceRange1 As Range, sourceRange2 As Range

' 定义要复制的目标区域（含标题行）
If lRow > dRow Then
    Set sourceRange1 = Range("B5:E" & lRow)
    Set sourceRange2 = Range("G5:H" & lRow)
Else
    Set sourceRange1 = Range("B5:E" & dRow)
    Set sourceRange2 = Range("G5:H" & dRow)
End If

' 创建临时工作表
Set tempWs = ThisWorkbook.Worksheets.Add
tempWs.Name = "PrintTemp"

' 将非连续区域复制为临时表的连续列
sourceRange1.Copy tempWs.Range("A1")
sourceRange2.Copy tempWs.Range("E1")

' 设置临时表打印参数
Application.PrintCommunication = False
With tempWs.PageSetup
    .Zoom = False
    .FitToPagesTall = False
    .FitToPagesWide = 1
    .PrintTitleRows = "$1:$1" ' 临时表第1行为原表头
End With
Application.PrintCommunication = True

' 打印预览/直接打印
tempWs.PrintPreview ' 如需直接打印可替换为 tempWs.PrintOut

' 删除临时工作表
Application.DisplayAlerts = False
tempWs.Delete
Application.DisplayAlerts = True
    
ElseIf Not Intersect(Target, Range("C1")) Is Nothing Then
    'EmailSheet
    Mail_Selection_Range_Outlook_Body
End If
End Sub

内容的提问来源于stack exchange，提问作者middleschoolteacher