清单保持单元格底边对齐的研究

因为合并单元格的不同，导致需要多重判断，异常难做，BUG很多，仅作留档备份

基本履职和上收事项适用

Option Explicit

Public Sub AdjustPageRowHeights()
    ' --- 声明变量 ---
    Dim ws As Worksheet
    Dim sel As Range
    Dim hPageBreaks As hPageBreaks
    Dim hpb As HPageBreak
    Dim startRow As Long, endRow As Long, lastRowInSelection As Long
    Dim i As Long
    Dim titleRows As Range
    
    ' --- 初始化和错误处理 ---
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False

    ' --- 环境设置 ---
    Set ws = ActiveSheet
    ' 检查用户是否已选择一个区域
    If TypeName(Selection) <> "Range" Then
        MsgBox "请先选择一个单元格区域。", vbInformation
        GoTo CleanExit
    End If
    Set sel = Selection

    ' 切换到分页预览模式以读取分页符
    ActiveWindow.View = xlPageBreakPreview

    ' --- 自动识别并解析“顶端标题行” ---
    Set titleRows = Nothing
    If ws.PageSetup.PrintTitleRows <> "" Then
        On Error Resume Next ' 忽略因无效地址引发的错误
        Set titleRows = ws.Range(ws.PageSetup.PrintTitleRows)
        On Error GoTo ErrorHandler ' 恢复错误处理
    End If

    ' --- 主循环：从后往前处理每一页，避免插入行时破坏分页符的引用 ---
    Set hPageBreaks = ws.hPageBreaks
    ' 获取选中区域的最后一行行号
    lastRowInSelection = sel.Row + sel.Rows.Count - 1
    endRow = lastRowInSelection

    For i = hPageBreaks.Count To 1 Step -1
        Set hpb = hPageBreaks(i)
        ' 确保分页符在选中区域内
        If hpb.Location.Row > sel.Row And hpb.Location.Row <= lastRowInSelection + 1 Then
            startRow = hpb.Location.Row
            ' 调用子程序处理当前页
            ProcessPage sel, startRow, endRow, titleRows
            ' 为上一页（下一次循环）设置结束行
            endRow = startRow - 1
        End If
    Next i

    ' --- 处理第一页（循环未覆盖的区域） ---
    startRow = sel.Row
    ProcessPage sel, startRow, endRow, titleRows

CleanExit:
    ' --- 恢复设置 ---
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    ' --- 统一错误处理 ---
    MsgBox "处理过程中发生错误：" & vbCrLf & Err.Description, vbCritical
    GoTo CleanExit
End Sub


Private Sub ProcessPage(ByVal sel As Range, ByVal pageStartRow As Long, ByVal pageEndRow As Long, ByVal titleRows As Range)
    ' --- 定义常量 ---
    Const TARGET_HEIGHT As Double = 758      ' 目标页面总行高（磅）
    Const MAX_ROW_HEIGHT As Double = 409     ' Excel最大行高（磅）
    Const MIN_ROW_HEIGHT As Double = 1       ' 最小行高（磅）

    ' --- 声明变量 ---
    Dim ws As Worksheet
    Dim pageRows As Range, dataRows As Range
    Dim totalHeight As Double, heightToAdd As Double, avgHeightToAdd As Double
    Dim dataRowCount As Long
    Dim r As Range, c As Range, area As Range
    Dim rowIndex As Long
    Dim origCell As Range, newCell As Range
    Dim selOnRow As Range
    
    Set ws = sel.Worksheet
    
    ' --- 1. 获取当前页面上属于选中区域的行 ---
    On Error Resume Next
    Set pageRows = Intersect(ws.Rows(pageStartRow & ":" & pageEndRow), sel)
    On Error GoTo 0
    If pageRows Is Nothing Then Exit Sub ' 如果此页没有选中的行，则退出

    ' --- 2. 计算页面上所有“数据行”（非标题行）的总高度和数量 ---
    totalHeight = 0
    dataRowCount = 0
    Set dataRows = Nothing

    For Each r In pageRows.Rows
        Dim isTitle As Boolean
        isTitle = False
        ' 检查当前行是否为标题行
        If Not titleRows Is Nothing Then
            If Not Intersect(r, titleRows) Is Nothing Then
                isTitle = True
            End If
        End If

        ' 如果不是标题行，则累加其高度和数量
        If Not isTitle Then
            totalHeight = totalHeight + r.RowHeight
            dataRowCount = dataRowCount + 1
            ' 将所有数据行合并到一个Range对象中以便后续操作
            If dataRows Is Nothing Then
                Set dataRows = r
            Else
                Set dataRows = Union(dataRows, r)
            End If
        End If
    Next r

    ' 如果此页没有数据行（可能只有标题行），则退出
    If dataRows Is Nothing Then Exit Sub

    ' --- 3. 检查是否需要调整 ---
    ' ********************************************************************
    ' ***** BUG修复点：如果当前页总行高已经满足或超过目标值，则不做任何处理 *****
    ' ********************************************************************
    If totalHeight >= TARGET_HEIGHT Then Exit Sub

    ' --- 4. 执行调整 (只有在 totalHeight < TARGET_HEIGHT 时才会执行到这里) ---
    heightToAdd = TARGET_HEIGHT - totalHeight

    ' --- 情况一：页面上只有一行数据 ---
    If dataRowCount = 1 Then
        rowIndex = dataRows.Row
        
        ' 禁用事件以避免连锁反应
        Application.EnableEvents = False
        
        ' 在该行下方插入一个新行
        ws.Rows(rowIndex + 1).Insert Shift:=xlShiftDown

        ' 获取原始选中区域中位于此行的单元格
        Set selOnRow = Intersect(dataRows, sel)

        ' 遍历这一行被选中的每个单元格，执行合并操作
        For Each c In selOnRow.Cells
            ' 只处理未合并单元格的起始单元格，避免重复操作
            If c.Row = rowIndex And Not c.MergeCells Then
                 Set origCell = ws.Cells(rowIndex, c.Column)
                 Set newCell = ws.Cells(rowIndex + 1, c.Column)

                 ' 复制格式到新行单元格
                 origCell.Copy
                 newCell.PasteSpecial Paste:=xlPasteFormats
                 Application.CutCopyMode = False

                 ' 垂直合并单元格并保持格式
                 ws.Range(origCell, newCell).Merge
                 origCell.WrapText = True
            End If
        Next c
        
        ' 设置合并后的两行高度，使其总和为目标高度
        ws.Rows(rowIndex).RowHeight = MAX_ROW_HEIGHT
        ws.Rows(rowIndex + 1).RowHeight = TARGET_HEIGHT - MAX_ROW_HEIGHT

        ' 恢复事件
        Application.EnableEvents = True

    ' --- 情况二：页面上有多行数据 ---
    ElseIf dataRowCount > 1 Then
        ' 首次尝试平均分配增量高度
        avgHeightToAdd = heightToAdd / dataRowCount
        For Each r In dataRows.Rows
            Dim newHeight As Double
            newHeight = r.RowHeight + avgHeightToAdd
            
            ' 检查是否超出最大行高限制
            If newHeight > MAX_ROW_HEIGHT Then newHeight = MAX_ROW_HEIGHT
            ' 因为只增高，所以无需检查最小行高，但保留以防万一
            If newHeight < MIN_ROW_HEIGHT Then newHeight = MIN_ROW_HEIGHT
            r.RowHeight = newHeight
        Next r

        ' --- 重新计算总高和剩余差值（由于部分行达到高度上限导致） ---
        totalHeight = 0
        For Each r In dataRows.Rows
            totalHeight = totalHeight + r.RowHeight
        Next r
        heightToAdd = TARGET_HEIGHT - totalHeight

        ' --- 第二次分配：将剩余差值分配给尚未达到高度上限的行 ---
        Dim adjustableRows As Range
        Dim adjustableRowCount As Long
        Set adjustableRows = Nothing
        adjustableRowCount = 0
        
        For Each r In dataRows.Rows
            If r.RowHeight < MAX_ROW_HEIGHT Then
                adjustableRowCount = adjustableRowCount + 1
                If adjustableRows Is Nothing Then Set adjustableRows = r Else Set adjustableRows = Union(adjustableRows, r)
            End If
        Next r

        If adjustableRowCount > 0 And Abs(heightToAdd) > 0.1 Then
            avgHeightToAdd = heightToAdd / adjustableRowCount
            For Each r In adjustableRows.Rows
                 Dim currentHeight As Double
                 currentHeight = r.RowHeight
                 
                 If currentHeight + avgHeightToAdd > MAX_ROW_HEIGHT Then
                     r.RowHeight = MAX_ROW_HEIGHT
                 Else
                     r.RowHeight = currentHeight + avgHeightToAdd
                 End If
            Next r
        End If

        ' --- 最后修正：将任何微小的计算误差加到最后一数据行上，确保总和精确 ---
        totalHeight = 0
        For Each r In dataRows.Rows
            totalHeight = totalHeight + r.RowHeight
        Next r
        heightToAdd = TARGET_HEIGHT - totalHeight
        
        If Abs(heightToAdd) > 0.01 Then
            ' 找到最后一区域的最后一行
            Set area = dataRows.Areas(dataRows.Areas.Count)
            Set r = area.Rows(area.Rows.Count)
            ' 确保调整后的高度在有效范围内
            If r.RowHeight + heightToAdd > MIN_ROW_HEIGHT And r.RowHeight + heightToAdd <= MAX_ROW_HEIGHT Then
                r.RowHeight = r.RowHeight + heightToAdd
            End If
        End If
    End If
End Sub

配合履职适用

Option Explicit

' 主程序：分析分页并循环处理每一页
Public Sub AdjustPageRowHeights_1040pt_Final()
    ' --- 声明变量 ---
    Dim ws As Worksheet
    Dim sel As Range
    Dim hPageBreaks As HPageBreaks
    Dim hpb As HPageBreak
    Dim startRow As Long, endRow As Long, lastRowInSelection As Long
    Dim i As Long
    Dim titleRows As Range
    
    ' --- 初始化和错误处理 ---
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False

    ' --- 环境设置 ---
    Set ws = ActiveSheet
    ' 检查用户是否已选择一个区域
    If TypeName(Selection) <> "Range" Then
        MsgBox "请先选择一个单元格区域。", vbInformation
        GoTo CleanExit
    End If
    Set sel = Selection

    ' 切换到分页预览模式以准确读取分页符
    ActiveWindow.View = xlPageBreakPreview

    ' --- 自动识别并解析“顶端标题行” ---
    Set titleRows = Nothing
    If ws.PageSetup.PrintTitleRows <> "" Then
        On Error Resume Next ' 忽略因无效地址引发的错误
        Set titleRows = ws.Range(ws.PageSetup.PrintTitleRows)
        On Error GoTo ErrorHandler ' 恢复错误处理
    End If

    ' --- 主循环：从后往前处理每一页，避免插入行时破坏分页符的引用 ---
    Set hPageBreaks = ws.HPageBreaks
    ' 获取选中区域的最后一行行号
    lastRowInSelection = sel.Row + sel.Rows.Count - 1
    endRow = lastRowInSelection

    For i = hPageBreaks.Count To 1 Step -1
        Set hpb = hPageBreaks(i)
        ' 确保分页符在选中区域内
        If hpb.Location.Row > sel.Row And hpb.Location.Row <= lastRowInSelection + 1 Then
            startRow = hpb.Location.Row
            ' 调用子程序处理当前页
            ProcessPage sel, startRow, endRow, titleRows
            ' 为上一页（下一次循环）设置结束行
            endRow = startRow - 1
        End If
    Next i

    ' --- 处理第一页（循环未覆盖的区域） ---
    startRow = sel.Row
    ProcessPage sel, startRow, endRow, titleRows

CleanExit:
    ' --- 恢复设置 ---
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    ' --- 统一错误处理 ---
    MsgBox "处理过程中发生错误：" & vbCrLf & Err.Description, vbCritical
    GoTo CleanExit
End Sub


' 核心处理子程序：根据行数在新规则下调整单页行高
Private Sub ProcessPage(ByVal sel As Range, ByVal pageStartRow As Long, ByVal pageEndRow As Long, ByVal titleRows As Range)
    ' --- 定义常量 ---
    Const TARGET_HEIGHT As Double = 1040    ' 目标页面总行高（磅）
    Const MAX_ROW_HEIGHT As Double = 409    ' Excel最大行高（磅）
    Const MIN_ROW_HEIGHT As Double = 1      ' 最小行高（磅）

    ' --- 声明变量 ---
    Dim ws As Worksheet
    Dim pageRows As Range, dataRows As Range
    Dim totalHeight As Double, heightToAdd As Double, avgHeightToAdd As Double
    Dim dataRowCount As Long
    Dim r As Range, area As Range
    Dim rowIndex As Long, i As Long, col As Long
    Dim cellToCheck As Range, rangeToMerge As Range
    
    Set ws = sel.Worksheet
    
    ' --- 1. 获取当前页面上属于选中区域的行 ---
    On Error Resume Next
    Set pageRows = Intersect(ws.Rows(pageStartRow & ":" & pageEndRow), sel)
    On Error GoTo 0 ' 恢复默认错误处理
    If pageRows Is Nothing Then Exit Sub ' 如果此页没有选中的行，则退出

    ' --- 2. 计算页面上所有“数据行”（非标题行）的总数和集合 ---
    totalHeight = 0
    dataRowCount = 0
    Set dataRows = Nothing

    For Each r In pageRows.Rows
        Dim isTitle As Boolean: isTitle = False
        If Not titleRows Is Nothing Then
            If Not Intersect(r, titleRows) Is Nothing Then isTitle = True
        End If

        If Not isTitle Then
            totalHeight = totalHeight + r.RowHeight
            dataRowCount = dataRowCount + 1
            If dataRows Is Nothing Then Set dataRows = r Else Set dataRows = Union(dataRows, r)
        End If
    Next r

    If dataRows Is Nothing Or dataRowCount = 0 Then Exit Sub

    ' --- 3. 根据页面数据行数执行不同逻辑 ---
    Application.EnableEvents = False ' 禁用事件以避免连锁反应并提高性能

    Select Case dataRowCount
        Case 1
            ' --- 情况一：页面上只有一行数据 ---
            ' 无论当前行高多少，都执行插入和合并操作
            rowIndex = dataRows.Row
            
            ' 在该行下方插入两个新行，并继承格式
            ws.Rows(rowIndex + 1 & ":" & rowIndex + 2).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
            
            ' 遍历选中区域的每一列，处理合并
            For col = sel.Column To sel.Column + sel.Columns.Count - 1
                Set cellToCheck = ws.Cells(rowIndex, col)
                ' 关键：确保只从合并区域的左上角单元格开始处理，以正确处理已合并的单元格且避免重复操作
                If cellToCheck.MergeArea.Cells(1, 1).Address = cellToCheck.Address Then
                    ' 定义要合并的目标范围（原始合并区域 + 下方2行）
                    Set rangeToMerge = ws.Range(cellToCheck.MergeArea, cellToCheck.MergeArea.Offset(2, 0))
                    rangeToMerge.Merge
                    rangeToMerge.VerticalAlignment = xlCenter
                    rangeToMerge.WrapText = True
                End If
            Next col
            
            ' 分配三行的高度以达到目标总高
            ws.Rows(rowIndex).RowHeight = MAX_ROW_HEIGHT
            ws.Rows(rowIndex + 1).RowHeight = MAX_ROW_HEIGHT
            ws.Rows(rowIndex + 2).RowHeight = Application.WorksheetFunction.Max(MIN_ROW_HEIGHT, TARGET_HEIGHT - (2 * MAX_ROW_HEIGHT))

        Case 2
            ' --- 情况二：页面上有两行数据 ---
            ' 无论当前行高多少，都为每行执行插入和合并操作
            ' 从后往前处理这两行，避免插入操作影响前方行的索引
            For i = dataRows.Rows.Count To 1 Step -1
                Set r = dataRows.Rows(i)
                rowIndex = r.Row
                
                ' 在当前行下方插入一个新行，并继承格式
                ws.Rows(rowIndex + 1).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
                
                ' 遍历选中区域的每一列，处理合并
                For col = sel.Column To sel.Column + sel.Columns.Count - 1
                    Set cellToCheck = ws.Cells(rowIndex, col)
                    If cellToCheck.MergeArea.Cells(1, 1).Address = cellToCheck.Address Then
                        Set rangeToMerge = ws.Range(cellToCheck.MergeArea, cellToCheck.MergeArea.Offset(1, 0))
                        rangeToMerge.Merge
                        rangeToMerge.VerticalAlignment = xlCenter
                        rangeToMerge.WrapText = True
                    End If
                Next col
                
                ' 分配这两行的高度，使其总和为目标高度的一半 (520磅)
                ws.Rows(rowIndex).RowHeight = MAX_ROW_HEIGHT
                ws.Rows(rowIndex + 1).RowHeight = Application.WorksheetFunction.Max(MIN_ROW_HEIGHT, (TARGET_HEIGHT / 2) - MAX_ROW_HEIGHT)
            Next i

        Case Else
            ' --- 情况三：页面上有多于两行数据（维持旧逻辑）---
            ' 仅当总高度不足时，才增加行高
            If totalHeight >= TARGET_HEIGHT Then GoTo CleanUp
            
            heightToAdd = TARGET_HEIGHT - totalHeight
            
            ' 首次尝试平均分配增量高度
            avgHeightToAdd = heightToAdd / dataRowCount
            For Each r In dataRows.Rows
                Dim newHeight As Double
                newHeight = r.RowHeight + avgHeightToAdd
                If newHeight > MAX_ROW_HEIGHT Then newHeight = MAX_ROW_HEIGHT
                If newHeight < MIN_ROW_HEIGHT Then newHeight = MIN_ROW_HEIGHT
                r.RowHeight = newHeight
            Next r

            ' 重新计算总高和剩余差值（由于部分行可能已达到高度上限）
            totalHeight = 0
            For Each r In dataRows.Rows: totalHeight = totalHeight + r.RowHeight: Next r
            heightToAdd = TARGET_HEIGHT - totalHeight

            ' 第二次分配：将剩余差值分配给尚未达到高度上限的行
            Dim adjustableRows As Range, adjustableRowCount As Long
            Set adjustableRows = Nothing: adjustableRowCount = 0
            For Each r In dataRows.Rows
                If r.RowHeight < MAX_ROW_HEIGHT Then
                    adjustableRowCount = adjustableRowCount + 1
                    If adjustableRows Is Nothing Then Set adjustableRows = r Else Set adjustableRows = Union(adjustableRows, r)
                End If
            Next r

            If adjustableRowCount > 0 And Abs(heightToAdd) > 0.1 Then
                avgHeightToAdd = heightToAdd / adjustableRowCount
                For Each r In adjustableRows.Rows
                    Dim currentHeight As Double: currentHeight = r.RowHeight
                    If currentHeight + avgHeightToAdd > MAX_ROW_HEIGHT Then
                        r.RowHeight = MAX_ROW_HEIGHT
                    Else
                        r.RowHeight = currentHeight + avgHeightToAdd
                    End If
                Next r
            End If
            
            ' 最后修正：将任何微小的计算误差加到最后一数据行上
            totalHeight = 0
            For Each r In dataRows.Rows: totalHeight = totalHeight + r.RowHeight: Next r
            heightToAdd = TARGET_HEIGHT - totalHeight
            
            If Abs(heightToAdd) > 0.01 Then
                Set area = dataRows.Areas(dataRows.Areas.Count)
                Set r = area.Rows(area.Rows.Count)
                If r.RowHeight + heightToAdd > MIN_ROW_HEIGHT And r.RowHeight + heightToAdd <= MAX_ROW_HEIGHT Then
                    r.RowHeight = r.RowHeight + heightToAdd
                End If
            End If
    End Select

CleanUp:
    ' --- 恢复事件 ---
    Application.EnableEvents = True
End Sub