在 VBA 中检测 Excel 工作簿下一个分页符的最佳方法是什么？

Question

我正在创建一个宏，将可变长度的数据编译到工作表上。此工作表上的数据量可以少至一行数据，多至数百行数据（所有行的列范围都是固定的 (A:I)）。在最后一行数据之后，需要有一个“页脚”。此“页脚”不能放置在 Excel 的页脚部分中，但必须占据工作表的最后 5 行。当用户保存工作表时（无论它是 excel、pdf 还是 word 格式），“页脚”不能在两页之间拆分。我已经构建了一个宏来计算哪一行将成为下一页的开始。对于此工作表，10 行等于一页。第 11 行将是下一页的开始。依此类推（第 3 页从第 21 行开始）。这个宏有效是因为我确保所有行的高度都为 40 (.RowHeight = 40)。但是，这种宏方法将不再适用，因为某些单元格中的数据可能包含足够的字符来环绕，要求行长于 40。在新分页符之前检测工作表上最后一行的更好方法是什么开始？

这是我当前的代码，用于检测页脚是否适合工作表的最后一页，或者页脚是否需要应用于下一页（并避免在分页符的中间添加）。同样，此代码现在不起作用，因为我不能依赖所有行都是恒定的高度值。关于以下代码的一些其他注意事项： FindLastRow 是一个函数，它根据提供的参数（工作表名称和列号）查找最后一个范围地址。使用 .Row 仅返回地址的行值。 COA 工作表上的第一行数据从第 13 行开始。第 1:12 行专用于文档标题信息。正如用户指定的那样，如果页脚必须放在一个单独的页面上，那么至少有一行数据也必须移动到那个新页面上（希望这能更好地解释最后一个 IF/Else 中所有额外的代码行将页脚添加到下一页时的声明）。感谢您的帮助和建议。

Public Sub COA_DetectedEOD()
'Purpose: Sub checks when the COA document ends and determines where
'the footer will go.
'If footer does not fit on the current last page of the document,
'then the last data point is cut/pasted at the start of the next new page
'and the footer is placed at the bottom of that new page.
Dim ws As Worksheet
Dim Lrow As Integer, i As Integer, cnt As Integer
Dim PgBtm As Integer, FtReq As Integer

Set ws = ThisWorkbook.Worksheets("COA")
Lrow = FindLastRow(ws, 1).Row   'Find the last row on COA sheet

FtReq = 4   'Number of rows required for footer to fit on page.
PgBtm = 22  'Row number of last row on COA page
i = 1       'COA page count
cnt = Lrow  'counter to calculate # of pages on COA.

'Determine how many pages are on the COA sheet
Do While cnt > 22
    cnt = cnt - 10  'each COA page is 10 rows
    i = i + 1       'count # of pages
Loop

'Update PgBtm variable with the last row number on page
PgBtm = (i * 10) + 12

'------------------------ ADD FOOTER ------------------------
If PgBtm - Lrow > FtReq Then
    Call COA_InsertFooter(Lrow + 2) 'The "+2" ensures the footer has a little separation from the data. 
Else
    'The page is too full for the footer to fit. Move last data row to the next new page
    ws.Rows(Lrow).EntireRow.Cut ws.Range("A" & PgBtm + 1)
    'Re-format row height on cut row (row Height goes back to default)
    ws.Range("A" & Lrow).RowHeight = 40
    'Add Footer to the bottom of the page
    Call COA_InsertFooter(PgBtm + 10 - FtReq)
End If

Terminate:
Set ws = Nothing
End Sub

Answer 1

这里是代码草案：

Sub SubInsertFooter()
    
    Dim RngPrint As Range
    Dim RngFooter As Range
    Dim RngRow As Range
    Dim DblFooterRowsHeight As Double
    Dim DblFooterSingleRowHeight As Double
    Dim DblMaxHeight As Double
    Dim DblHeightSum As Double
    Dim DblRow As Double
    Dim DblCounter As Double
    Dim DblUsedRangeRowsHeight() As Double
    
    ActiveSheet.ClearContents
    
    Set RngPrint = Range("A11:G60")
    Set RngFooter = Range("A1:G5")
    
    DblFooterSingleRowHeight = 40
    DblFooterRowsHeight = DblFooterSingleRowHeight * 5
    DblMaxHeight = DblFooterSingleRowHeight * 10
    
    RngPrint.FormulaR1C1 = "=ROW(RC)+1-" & RngPrint.Row
    RngPrint.Value2 = RngPrint.Value2
    
    RngFooter.Value2 = "FOOTER"
    RngFooter.Columns(1).Value2 = DblFooterSingleRowHeight
    
    For Each RngRow In RngPrint.Rows
        
        Randomize
        RngRow.RowHeight = (Rnd() * 2 + 1) * 20
        RngRow.Cells(1, 1).Value2 = RngRow.EntireRow.RowHeight
        
    Next
    
    MsgBox "Here i stop the code so you can check the initial data. You can resume the code once you've had your look.", vbInformation + vbOKOnly
    Stop
    
    ReDim DblUsedRangeRowsHeight(1 To ActiveSheet.UsedRange.Rows.Count, 0 To 1) As Double
    
    With ActiveSheet.UsedRange
        For DblRow = 1 To .Rows.Count
            DblUsedRangeRowsHeight(DblRow, 0) = .Rows(DblRow).RowHeight
        Next
    End With
    
    For Each RngRow In RngPrint.Rows
        
        Select Case DblHeightSum + RngRow.RowHeight + DblFooterRowsHeight
            Case Is < DblMaxHeight
                DblHeightSum = DblHeightSum + RngRow.RowHeight
            Case Is = DblMaxHeight
                DblUsedRangeRowsHeight(RngRow.Row + 1, 1) = 1
                DblHeightSum = 0
            Case Is > DblMaxHeight
                DblUsedRangeRowsHeight(RngRow.Row, 1) = 1
                DblHeightSum = RngRow.RowHeight
        End Select
        If Range(RngRow, RngPrint.Rows(RngPrint.Rows.Count)).Height + RngFooter.Height <= DblMaxHeight And DblHeightSum <= RngRow.RowHeight Then
            Exit For
        End If
    Next
    
    
    
    With RngPrint
        
        DblCounter = 0
        
        For DblRow = .Rows(.Rows.Count).Row + 1 To .Row Step -1
            Select Case True
                Case Is = DblCounter > 0
                    
                    For DblCounter = DblCounter To RngFooter.Rows.Count Step -1
                        
                        Set RngRow = Rows(DblRow).Offset(DblCounter)
                        RngRow.EntireRow.RowHeight = DblUsedRangeRowsHeight(DblRow + DblCounter - RngFooter.Rows.Count, 0)
                    Next
                    DblCounter = 0
                    
                Case Is = DblRow = .Rows(.Rows.Count).Row + 1, DblUsedRangeRowsHeight(DblRow, 1) = 1
                    RngFooter.Copy
                    Set RngRow = Rows(DblRow)
                    RngRow.Insert shift:=xlDown
                    Application.CutCopyMode = False
                    RngRow.Resize(RngFooter.Rows.Count).Rows.RowHeight = DblFooterSingleRowHeight
                    If DblRow <> .Rows(.Rows.Count).Row + 1 Then
                        DblCounter = DblCounter * -1 + RngFooter.Rows.Count
                        DblRow = DblRow + 1
                    End If
                Case Else
                    DblCounter = DblCounter - 1
            End Select
        Next
    End With
    
    
    
End Sub

将它放在一个模块中，选择一个新工作表并运行它。它将在 A1:G5 范围内粘贴一个假页脚，在 A11:G60 范围内粘贴一个具有随机行高的假列表。然后它会相应地将页脚添加到列表中。

这就是您正在寻找的算法吗？