VBA实现Excel指定范围单元格逐行复制粘贴至PPT独立文本框

• 编写VBA实现Excel指定单元格范围的逐行导出：将范围内每个单元格的内容单独粘贴到PPT的独立文本框中，首个单元格对应第一个文本框，依次向后匹配直到范围处理完成
• 现有代码可正常打开PPT、执行单元格筛选，但会将所有目标单元格内容合并粘贴到单个文本框，不符合分文本框填充的要求

Sub OpenPoints()
    Dim PPT As PowerPoint.Application
    Dim pres As PowerPoint.Presentation
    Dim sl As PowerPoint.Slide
    Dim sh As PowerPoint.Shape
    Dim sh1 As PowerPoint.Shape
    Dim r As Range
    Dim filterRange As Range
    Dim copyRange As Range
    Dim lastRow As Long

    'Open Powerpoint
    Set PPT = New PowerPoint.Application
    Set pres = PPT.Presentations.Open(ThisWorkbook.Path & "\Edenred_ProjectStatus_Saxo.pptx")

    'Insert open points description
    Set sl = pres.Slides(1)
    Set sh1 = sl.Shapes("Rectangle 40")

    'Filtra per "Y"
    ThisWorkbook.Sheets("Action&Open_Point").Range("H1").AutoFilter field:=1, Criteria1:="Y"

    'Individuazione ultima riga
    lastRow = ThisWorkbook.Sheets("Action&Open_Point").Range("D" & ThisWorkbook.Sheets("Action&Open_Point").Rows.Count).End(xlUp).Row

    'Copia colonna descrizione
    Set copyRange = ThisWorkbook.Sheets("Action&Open_Point").Range("D2:D" & lastRow)
    ActiveWorkbook.Worksheets("Action&Open_Point").UsedRange.Font.Underline = False
    copyRange.SpecialCells(xlCellTypeVisible).Copy
    sh1.TextFrame2.TextRange.PasteSpecial msoClipboardFormatRTF
End Sub

Sub OpenPoints()
    Dim PPT As Object
    Dim pres As Object
    Dim sl As Object
    Dim visibleCell As Range
    Dim copyRange As Range
    Dim lastRow As Long
    Dim shapeIndex As Long
    
    ' 按需修改以下配置，匹配你的PPT文本框规则
    Const PPT_SLIDE_INDEX As Long = 1
    Const SHAPE_NAME_PREFIX As String = "Rectangle "
    Const START_SHAPE_NUM As Long = 40
    Const msoClipboardFormatRTF As Long = 1

    ' 打开指定PPT文件
    Set PPT = CreateObject("PowerPoint.Application")
    PPT.Visible = True
    Set pres = PPT.Presentations.Open(ThisWorkbook.Path & "\Edenred_ProjectStatus_Saxo.pptx")

    ' 定位目标幻灯片
    Set sl = pres.Slides(PPT_SLIDE_INDEX)

    ' 按H列条件筛选值为"Y"的行
    ThisWorkbook.Sheets("Action&Open_Point").Range("H1").AutoFilter Field:=1, Criteria1:="Y"

    ' 获取D列最后一行行号
    lastRow = ThisWorkbook.Sheets("Action&Open_Point").Range("D" & ThisWorkbook.Sheets("Action&Open_Point").Rows.Count).End(xlUp).Row

    ' 定义待复制的D列范围
    Set copyRange = ThisWorkbook.Sheets("Action&Open_Point").Range("D2:D" & lastRow)
    ActiveWorkbook.Worksheets("Action&Open_Point").UsedRange.Font.Underline = False

    shapeIndex = 0
    ' 逐一遍历筛选后的可见单元格
    For Each visibleCell In copyRange.SpecialCells(xlCellTypeVisible)
        ' 复制当前单个单元格内容
        visibleCell.Copy
        ' 粘贴到对应序号的独立文本框
        sl.Shapes(SHAPE_NAME_PREFIX & START_SHAPE_NUM + shapeIndex).TextFrame2.TextRange.PasteSpecial msoClipboardFormatRTF
        shapeIndex = shapeIndex + 1
    Next visibleCell

    ' 清空剪贴板
    Application.CutCopyMode = False
End Sub

注：上述代码采用后期绑定写法，不需要手动引用PowerPoint对象库即可直接运行

• 代码完全保留原有业务逻辑：按H列"Y"值筛选、RTF格式粘贴、读取指定路径下的PPT文件，和原有代码行为一致
• 只需要修改代码开头的三个常量配置，即可匹配你自己的PPT结构：PPT_SLIDE_INDEX为文本框所在的幻灯片页码，SHAPE_NAME_PREFIX为文本框的名称前缀，START_SHAPE_NUM为第一个待填充文本框的序号
• 如果你的文本框命名没有连续数字规律，可以提前将所有待填充的文本框按顺序存入集合/数组，遍历单元格时按索引取出对应文本框粘贴即可
• 代码新增了PPT前台显示逻辑，避免PPT后台运行时出现无响应、进程残留问题

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