如何根据PowerPoint幻灯片高度按行高总和拆分复制Excel表格？

我目前采用固定20行的拆分方案，将超出幻灯片容量的Excel大型表格拆分后连同表头复制到新PowerPoint幻灯片（通过Excel VBA实现），关键代码如下：

Set wb = Workbooks("Planning.xlsm")
Set ws = wb.Sheets("LastYear")
Set wss = wb.Worksheets.Add
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Set myPresentation = PowerPointApp.ActivePresentation

Do While i <= LastRow
    j = Application.Min(i + 20, LastRow)
    Union(rngH, ws.Range("A" & i, ws.Range("M" & j))).Copy
    wss.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
    wss.Range("A1").PasteSpecial Paste:=xlPasteValues
    wss.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme

    Set sld = myPresentation.Slides.Add(myPresentation.Slides.Count + 1, ppLayoutBlank)
    wss.Range("A1:M" & j - i + 2).Copy
    
    sld.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse

    'Here title of the table & format is added
    Set Header = sld.Shapes.AddShape(msoShapeRectangle, 0, 0, 960, 40)
    With Header
        .Fill.ForeColor.RGB = RGB(0, 32, 91)
        .Line.Visible = False
    End With
Loop

之后通过PowerPoint宏调整表格尺寸以适配标题外的空间，但因表格行高不一，时常出现表格过长或过短的情况，需手动返工。请问能否根据PowerPoint幻灯片高度及行高总和来拆分复制表格（即累加行高至匹配幻灯片可用高度）？我自行尝试未果，恳请提供帮助。

核心逻辑是：先计算幻灯片扣除标题栏后的可用高度，然后从当前行开始逐行累加Excel表格的行高，直到累加值接近可用高度时停止，以此动态确定每一页的拆分行数，替代固定20行的方案。

修改后的完整代码如下：

Sub SplitTableBySlideHeight()
    Dim wb As Workbook, ws As Worksheet, wss As Worksheet
    Dim PowerPointApp As Object, myPresentation As Object, sld As Object
    Dim rngH As Range
    Dim LastRow As Long, i As Long, j As Long
    Dim slideAvailableHeight As Double, currentRowHeightSum As Double
    Dim headerRowHeight As Double
    
    ' 初始化对象
    Set wb = Workbooks("Planning.xlsm")
    Set ws = wb.Sheets("LastYear")
    Set wss = wb.Worksheets.Add
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
    Set myPresentation = PowerPointApp.ActivePresentation
    
    ' 获取表头区域（假设表头是第1行，可根据实际修改）
    Set rngH = ws.Range("A1:M1")
    headerRowHeight = rngH.RowHeight ' 表头行高
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 计算幻灯片可用高度：幻灯片总高度 - 标题栏高度（你的标题栏是40）
    slideAvailableHeight = myPresentation.PageSetup.SlideHeight - 40
    
    i = 2 ' 从数据行第2行开始（表头是第1行）
    Do While i <= LastRow
        currentRowHeightSum = headerRowHeight ' 先计入表头行高
        j = i
        
        ' 逐行累加行高，直到接近可用高度
        Do While j <= LastRow
            currentRowHeightSum = currentRowHeightSum + ws.Rows(j).RowHeight
            ' 如果加上当前行后超出可用高度，就停止（减回当前行的高度，取上一行）
            If currentRowHeightSum > slideAvailableHeight Then
                currentRowHeightSum = currentRowHeightSum - ws.Rows(j).RowHeight
                j = j - 1
                Exit Do
            End If
            j = j + 1
        Loop
        
        ' 处理最后一页的边界情况
        If j > LastRow Then j = LastRow
        
        ' 复制表头+当前页数据到临时工作表
        Union(rngH, ws.Range("A" & i, "M" & j)).Copy
        wss.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
        wss.Range("A1").PasteSpecial Paste:=xlPasteValues
        wss.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        
        ' 添加新幻灯片并粘贴表格
        Set sld = myPresentation.Slides.Add(myPresentation.Slides.Count + 1, ppLayoutBlank)
        wss.Range("A1:M" & (j - i + 2)).Copy ' j-i+2是表头+数据行的总行数
        sld.Shapes.PasteSpecial DataType:=ppPasteHTML, Link:=msoFalse
        
        ' 添加标题栏（和原代码一致）
        Set Header = sld.Shapes.AddShape(msoShapeRectangle, 0, 0, 960, 40)
        With Header
            .Fill.ForeColor.RGB = RGB(0, 32, 91)
            .Line.Visible = False
        End With
        
        ' 清理临时工作表内容，准备下一页
        wss.Cells.Clear
        i = j + 1 ' 跳到下一组数据的起始行
    Loop
    
    ' 删除临时工作表
    Application.DisplayAlerts = False
    wss.Delete
    Application.DisplayAlerts = True
End Sub

关键说明： #

• 可用高度计算：通过myPresentation.PageSetup.SlideHeight获取幻灯片总高度，减去标题栏的40高度，得到表格可占用的最大高度。
• 动态累加行高：从当前数据行开始，逐行累加行高，一旦累加值超过可用高度，就回退到上一行，确保表格粘贴到PPT后不会超出可用空间。
• 临时工作表清理：每处理完一页就清空临时表，避免数据残留；最后删除临时表，保持Excel环境整洁。

内容的提问来源于stack exchange，提问作者Tim007