套打适应行高

Sub AdjustRowHeight0()
    Dim ModelSheet As Worksheet, PrintSheet As Worksheet
    Dim ModelRng As Range '模板单元格
    Dim modelRowHeight() As Double '模板行高数据
    Dim modelRowCount As Long '模板行数
    Dim sumModelHeight As Double '模板累计行高
    Dim adjustScale As Double '调整比例
    Const MODEL_COUNT = 5    ' 每一页放置多少个单据RowsInOnePage / modelRowCount
    Dim desRng As Range '粘贴位置
    Dim BreakRange As Range '水平分页符位置
    Dim PageHeight As Double '累计首页行高
    Dim i As Long '行号
    
    Set ModelSheet = ThisWorkbook.Worksheets("单据模板")
    Set PrintSheet = ThisWorkbook.Worksheets("批量打印")
    
    With ModelSheet
        If Application.WorksheetFunction.CountA(.Cells) > 0 Then
            '计数防止计算行号发生错误
            EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
            EndCol = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column
            '获取单据模板单元格区域
            Set ModelRng = .Range(.Cells(1, 1), .Cells(EndRow, EndCol))
            '获取模板单元格行数和累计行高
            modelRowCount = ModelRng.Rows.Count
            ReDim modelRowHeight(1 To modelRowCount)
            sumModelHeight = 0
            For i = 1 To modelRowCount
                modelRowHeight(i) = ModelRng.Rows(i).RowHeight
                sumModelHeight = sumModelHeight + ModelRng.Rows(i).RowHeight
            Next i
        End If
    End With
    
    With PrintSheet
        .Cells.Clear
        '批量复制单据模板
        For i = 1 To 25
            If Application.WorksheetFunction.CountA(.Cells) = 0 Then
                Set desRng = .Range("A1")
            Else
                EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 2
                Set desRng = .Cells(EndRow, 1)
            End If
            ModelRng.Copy desRng '实际操作时还需要填入数据
        Next i
        
        '只有内容超出一页时，Excel才会自动添加分页符
        If .HPageBreaks.Count > 0 Then
            '获取第一个垂直分页符所在的单元格
            Set BreakRange = .HPageBreaks(1).Location
            '累计第一页所有行的高度
            i = 1
            Do While i < BreakRange.Row
                PageHeight = PageHeight + .Rows(i).RowHeight
                i = i + 1
            Loop
            
            '获取最后一个成绩单末尾的空白行行号
            RowsInOnePage = BreakRange.Row
            Do While Application.WorksheetFunction.CountA(.Rows(RowsInOnePage)) > 0
                RowsInOnePage = RowsInOnePage - 1
            Loop
            '计算调整比例
            adjustScale = PageHeight / (sumModelHeight * MODEL_COUNT)
            
            '逐行调整
            EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
            r = 0
            For i = 1 To EndRow
                r = r + 1
                .Rows(i).RowHeight = modelRowHeight(r) * adjustScale
                If r = modelRowCount Then r = 0 '逐个单据调整
            Next i
            
        End If
        
    End With
    Set ModelSheet = Nothing: Set PrintSheet = Nothing
End Sub