该代码不是我写的,只是原代码是作用于手动填写的一整列,在存在合并单元格标题的处理时容易出错,我修改为了作用于选中区域。主要用于处理某一列存在合并单元格,但分页后,下一页合并单元格被拦腰斩断的问题,该代码会将被跨页的单元格进行分割,重新填入内容。
Sub 重组跨页合并单元格()
Dim p, MerageAddress As String, PageCell As Range, MergeValue
Dim selectedRange As Range
Dim col As Range
Dim columnIndex As Long
On Error GoTo tuichu
Set selectedRange = Selection ' 获取用户选中的区域
If selectedRange Is Nothing Then
MsgBox "请先选中要处理的单元格区域!"
Exit Sub
End If
Application.ScreenUpdating = False
ActiveWindow.View = xlPageBreakPreview ' 进入分页预览以判断分页符位置
For Each col In selectedRange.Columns
columnIndex = col.Column
For Each p In ActiveSheet.HPageBreaks ' 逐页循环,处理水平分页符
Set PageCell = Cells(p.Location.Row - 1, columnIndex) ' 设置分页前最后一个单元格
If PageCell.MergeCells And Not Intersect(Cells(p.Location.Row, columnIndex), PageCell.MergeArea) Is Nothing Then
MerageAddress = PageCell.MergeArea.Address ' 获取合并区域地址
MergeValue = PageCell.MergeArea(1).value ' 获取合并区域值
PageCell.MergeArea.UnMerge ' 取消合并
Range(Range(MerageAddress)(1), PageCell).Merge ' 合并本页部分
Range(Range(MerageAddress)(1), PageCell).Borders.LineStyle = xlContinuous ' 添加边框
With Range(PageCell.Offset(1, 0), Cells(Split(MerageAddress, "$")(4), columnIndex))
.Merge ' 合并下一页部分
.value = MergeValue ' 赋值
.HorizontalAlignment = xlCenter ' 水平居中
.VerticalAlignment = xlCenter ' 垂直居中
.Borders.LineStyle = xlContinuous ' 添加边框
End With
End If
Next p
Next col
Application.ScreenUpdating = True
ActiveWindow.View = xlNormalView ' 恢复常规视图
Set selectedRange = Nothing
Set PageCell = Nothing
tuichu:
End Sub