重组跨页的合并单元格

EXCEL及VBA · 06-19

该代码不是我写的,只是原代码是作用于手动填写的一整列,在存在合并单元格标题的处理时容易出错,我修改为了作用于选中区域。主要用于处理某一列存在合并单元格,但分页后,下一页合并单元格被拦腰斩断的问题,该代码会将被跨页的单元格进行分割,重新填入内容。

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

VBA EXCEL