VBA实现多Excel工作表数组导出PowerPoint时调整文本大小与位置

前置说明 #

你需要先在Excel VBA编辑器中启用PowerPoint对象库引用：依次点击「工具」>「引用」，勾选Microsoft PowerPoint [你的版本号] Object Library后确认即可。

修改思路 #

• 原代码仅存储了工作表、区域两个维度的配置，新增3个平行配置数组，分别对应每个区域的缩放比例、左侧边距、顶部边距，相同索引位置的参数对应同一个粘贴对象
• 粘贴时直接捕获生成的形状对象，直接操作该对象调整位置与尺寸
• 移除原代码中重复声明的PowerPoint变量，避免编译报错

完整可运行代码 #

Sub ExportMultipleRangeToPowerPoint_Method1()
    '声明PowerPoint变量
    Dim PPTApp As PowerPoint.Application
    Dim PPTPres As PowerPoint.Presentation
    Dim PPTSlide As PowerPoint.Slide
    Dim PPShape As PowerPoint.Shape
    
    '声明Excel变量
    Dim ExcRng As Range
    Dim ShtArray As Variant, RngArray As Variant
    Dim ZoomArray As Variant, LeftArray As Variant, TopArray As Variant
    Dim x As Integer
    
    '===== 配置区：可按需修改以下参数 =====
    '每个索引位置的参数对应同一个粘贴对象，顺序不要乱
    ShtArray = Array("Summary", "Sheet2", "Sheet3") '工作表名称
    RngArray = Array("A1:E16", "C2:E6", "B2:D6") '粘贴区域
    ZoomArray = Array(150, 120, 200) '缩放比例，单位%，100为原始大小
    LeftArray = Array(50, 100, 80) '距离PPT页面左侧的距离，单位磅
    TopArray = Array(80, 120, 150) '距离PPT页面顶部的距离，单位磅
    '====================================
    
    '创建PowerPoint实例
    Set PPTApp = New PowerPoint.Application
    PPTApp.Visible = True
    Set PPTPres = PPTApp.Presentations.Add
    
    '循环处理每个区域
    For x = LBound(RngArray) To UBound(RngArray)
        Set ExcRng = Worksheets(ShtArray(x)).Range(RngArray(x))
        ExcRng.Copy
        
        '新建空白幻灯片
        Set PPTSlide = PPTPres.Slides.Add(x + 1, ppLayoutBlank)
        
        '粘贴区域并捕获形状对象
        Set PPShape = PPTSlide.Shapes.PasteSpecial(ppPasteOLEObject, msoFalse)
        
        '调整位置
        PPShape.Left = LeftArray(x)
        PPShape.Top = TopArray(x)
        
        '等比例缩放
        PPShape.ScaleHeight ZoomArray(x) / 100, msoTrue, msoScaleFromTopLeft
        PPShape.ScaleWidth ZoomArray(x) / 100, msoTrue, msoScaleFromTopLeft
    Next x
    
    '释放对象
    Set PPShape = Nothing
    Set PPTSlide = Nothing
    Set PPTPres = Nothing
    Set PPTApp = Nothing
    Set ExcRng = Nothing
End Sub

可选调整方案 #

如果你不需要保留Excel对象的可编辑性，只想直接放大文本字号，可将粘贴方式替换为ppPasteHTML粘贴为PPT原生表格，再添加以下代码遍历调整字号：

'粘贴为原生表格
Set PPShape = PPTSlide.Shapes.PasteSpecial(ppPasteHTML)
'遍历所有单元格调整字号，示例为设置为14号字
Dim cell As PowerPoint.Cell
For Each cell In PPShape.Table.Cells
    cell.Shape.TextFrame.TextRange.Font.Size = 14
Next cell

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