'参考论坛里的资料 ，自己改了一下
Sub 跨页的合并单元格区域拆分以便打印()
Dim 标题, 选项
标题 = "跨页的合并单元格区域拆分以便打印,需要先设置一下打印区域"
选项 = MsgBox(" 是 : 已经按部分合并单元格局部调整分页符位置" & Chr(10) & " 否 : 在复制工作表上操作" & Chr(10) & "取消:退出并手动调整部分分页符位置 ", 3, 标题)
If 选项 = 6 Then
'
ElseIf 选项 = 7 Then
ActiveSheet.Copy After:=Worksheets(ActiveSheet.Index)
ActiveSheet.Name = "按分页分拆合并单元格" & Format(Now, "mmddhhmmss") & Int((9 * Rnd) + 1)
ElseIf 选项 = 2 Then
ActiveWindow.View = xlPageBreakPreview '打开分页预览，这样会出现分页符
Exit Sub
End If
Application.ScreenUpdating = False '防止眼花了
Application.DisplayAlerts = False '取消了警告提示
Dim rng As Range, A1 As Range, A2 As Range, My_str, My_str_1, My_str_2
Dim R, Nr, Nc, I As Integer, 边框线型, 线型粗细
Dim sht As Worksheet
Set sht = ActiveSheet
Dim Sel_R_Start, Sel_C_Start, Sel_R_End, Sel_C_End
Dim sel As Range
Dim s_str As String
With sht
ActiveWindow.View = xlPageBreakPreview '打开分页预览，这样会出现分页符
If .PageSetup.PrintArea = "" Then
.PageSetup.PrintArea = .UsedRange.Address
End If
s_str = .PageSetup.PrintArea
Set sel = Range(s_str)
Debug.Print sel.Address
Sel_R_Start = sel.Row
Sel_C_Start = sel.Column
Sel_R_End = sel.Rows.Count + sel.Row - 1
Sel_C_End = sel.Columns.Count + sel.Column - 1
If .HPageBreaks.Count > 0 Then '当大于一页时执行代码
For Nr = 1 To .HPageBreaks.Count '循环列举各个水平分页符位置
R = .HPageBreaks(Nr).Location.Row '取得当前列举到的水平分布所在的行的值
I = R '储存行值的备份
For Nc = Sel_C_Start To Sel_C_End
If .Cells(R, Nc).MergeCells = True And .Cells(R, Nc).MergeArea.Cells(1).Row < I Then
With .Cells(R, Nc).MergeArea '.Select '选中当前行的第一列的单元格
My_str = .Cells(1, 1).Value
My_str_1 = Split(.Address, "")
My_str_2(2) = I & ":"
Set A1 = Range(Join(My_str_1, ""))
边框线型 = .Borders(xlEdgeBottom).LineStyle
线型粗细 = .Borders(xlEdgeBottom).Weight
Debug.Print 边框线型
.UnMerge
With A1
.Merge
.Value = My_str
.Borders(xlEdgeBottom).LineStyle = 边框线型
.Borders(xlEdgeBottom).Weight = 线型粗细
End With
With A2
.Merge
.Value = My_str
.Borders(xlEdgeTop).LineStyle = 边框线型
.Borders(xlEdgeTop).Weight = 线型粗细
End With
End With
End If
Next Nc
Next Nr '下一个水平分页符
End If
' ActiveWindow.View = xlPageBreakPreview
ActiveWindow.View = xlNormalView '处理完成，恢复到普通视图
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True '打开警告提示
End Sub
复制代码