20190316xlVba_设置行高的改进方案

Public Sub AutoSetRowHeight(ByVal sht As Worksheet, Optional RowsInOnePage As Long)
    Dim BreakRow As Range '水平分页符位置
    Dim SumHeight As Double '累计首页行高
    Dim AverageHeight As Double
    Dim RestHeight As Double
    Dim i As Long '行号
    With sht
        '获取第一页与第二页分页符所在的单元格
        Set BreakRow = sht.HPageBreaks(1).Location
        Debug.Print "首页分页符所在的行号："; BreakRow.Row
        '累计第一页所有行的高度
        i = 1
        Do While i < BreakRow.Row
            
            SumHeight = SumHeight + .Rows(i).RowHeight
            i = i + 1
        Loop
        Debug.Print "计算行号尾号  "; i - 1
        '获取第一页最后一个成绩单末尾的空白行行号
        If IsMissing(RowsInOnePage) Then
            RowsInOnePage = BreakRow.Row
            Do While .Cells(RowsInOnePage, 2).Value <> ""
                RowsInOnePage = RowsInOnePage - 1
            Loop
            Debug.Print "首页最后一个成绩单截止行号："; RowsInOnePage
        End If
        '计算平均行高
        Debug.Print "单页总行高 ： "; SumHeight
        If RowsInOnePage <> 0 Then
            AverageHeight = SumHeight / RowsInOnePage
        Else
            MsgBox "除零错误"
            'GoTo ErrHandler
            Exit Sub
        End If
        '设置已用区域的行高
        'AverageHeight = IIf(AverageHeight - Int(AverageHeight) > 0.5, Int(AverageHeight) + 1, Int(AverageHeight) + 0.5)
        
        
        
        
        '########################
        '行高最小设置单位为0.25 改进方案，现将N-1行缩小一点，再将第N行放大一点
        AverageHeight = Int(AverageHeight / 0.25) * 0.25 '截取0.25的倍数部分
        RestHeight = SumHeight - AverageHeight * (RowsInOnePage - 1)
        .UsedRange.Rows.RowHeight = AverageHeight
        
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        For i = 1 To EndRow
            If i Mod RowsInOnePage = 0 Then .Rows(i).RowHeight = RestHeight
        Next i
        
        
        '首页仍然后剩余 进入调整方案
        Set BreakRow = sht.HPageBreaks(1).Location
        FirstEnd = BreakRow.Row - 1
        
        If FirstEnd > RowsInOnePage Then
            Do While .Cells(FirstEnd, 1).Value <> ""
                For i = FirstEnd To 1 Step -1
                    If .Cells(i, 1).Value = "" Then
                        lastBlank = i
                        Exit For
                    End If
                Next i
                NewHeight = .Rows(lastBlank).RowHeight + 0.25
                .Rows(lastBlank).RowHeight = NewHeight
                Set Rng = sht.HPageBreaks(1).Location
                FirstEnd = Rng.Row - 1
            Loop
            EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
            For i = 1 To EndRow
                If i Mod RowsInOnePage = 0 Then .Rows(i).RowHeight = NewHeight
            Next i
        End If
        
    End With
    '释放
    Set sht = Nothing
    Set BreakRow = Nothing
End Sub