使用 VBA 从 Excel 复制/粘贴到 PowerPoint 的位置和大小问题

Question

我需要使用 VBA 命令将我在 excel 中的表格复制/粘贴到 powerpoint 中。

我找到了这个视频：https://www.youtube.com/watch?v=dIqoXYy_Clg

它完全响应了我想要做的事情，唯一的区别是我希望我的所有表格都在同一张幻灯片上。

但是，当我运行 sub 时，前两个表的位置和大小都正确，但在第三个之后，它们都进入幻灯片的中间，我应用的宽度也发生了变化。我发现当您从 excel 复制/粘贴到 powerpoint 时，它们在定位方面存在一些问题，但我想知道是否有办法在粘贴后强制表格按照我最初指定的方式移动和调整大小。

这是实际代码：

Sub ExporttoPPT()

Dim ppt_app As New PowerPoint.Application
Dim pre As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range

Dim vSheet$
Dim vRange$
Dim vWidth As Double
Dim vHeight As Double
Dim vTop As Double
Dim vLeft As Double
Dim vShape As Double
Dim expRng As Range

Dim Export_PPT_Sh As Worksheet
Dim ConfigRng As Range
Dim xlfile$
Dim pptfile$

Set Export_PPT_Sh = ThisWorkbook.Sheets("Export_PPT")

xlfile = Export_PPT_Sh.[excelPth]
pptfile = Export_PPT_Sh.[pptPth]


Set wb = Workbooks.Open(xlfile)
Set pre = ppt_app.Presentations.Open(pptfile)
Set ConfigRng = Export_PPT_Sh.Range("Rng_Sheets")


For Each rng In ConfigRng

    
    With Export_PPT_Sh
        vSheet$ = .Cells(rng.Row, 4).Value
        vRange$ = .Cells(rng.Row, 5).Value
        vWidth = .Cells(rng.Row, 6).Value
        vHeight = .Cells(rng.Row, 7).Value
        vTop = .Cells(rng.Row, 8).Value
        vLeft = .Cells(rng.Row, 9).Value
        vShape = .Cells(rng.Row, 10).Value
    End With

    
             wb.Activate
             Sheets(vSheet$).Activate
             Set expRng = Sheets(vSheet$).Range(vRange$)
             expRng.Copy
    
             Set sld = pre.Slides(1)
             sld.Shapes.PasteSpecial ppPasteBitmap
             Set shp = sld.Shapes(vShape)
    
             With shp
                .Width = vWidth
                .Height = vHeight
                .Top = vTop
                .Left = vLeft
             End With
             
        Set sld = Nothing
        Set shp = Nothing
        Set expRng = Nothing
   
Next rng

Set pre = Nothing
Set ppt_app = Nothing

wb.Close False
Set wb = Nothing

End Sub

我的 excel 表格上有一个包含所有属性的范围，例如宽度、高度等... 如果相关，我也在 excel 和 powerpoint 2013 上。

这是我的第一篇文章，所以我希望我已经足够清楚了。提前感谢您的回复。

Answer 1

感谢 John Korchock，我尝试使用占位符而不是定义宽度、高度等...

这样，表格总是按照预期的位置和大小排列。代码最终看起来像这样：

Sub ExporttoPPT()

Dim ppt_app As New PowerPoint.Application
Dim pre As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range

Dim vSheet$
Dim vRange$
Dim vPlcHolder As Long
Dim expRng As Range

Dim Export_PPT_Sh As Worksheet
Dim ConfigRng As Range
Dim xlfile$
Dim pptfile$

Set Export_PPT_Sh = ThisWorkbook.Sheets("Export_PPT")

'Path of the PowerPoint template and the excel worbook.
xlfile = Export_PPT_Sh.[excelPth]
pptfile = Export_PPT_Sh.[pptPth]

'Opening the excel and ppt workbooks
Set wb = Workbooks.Open(xlfile)
Set pre = ppt_app.Presentations.Open(pptfile)
Set ConfigRng = Export_PPT_Sh.Range("Rng_Sheets")

'Variables
For Each rng In ConfigRng

    'Set Variables for tables 
    With Export_PPT_Sh
        vSheet$ = .Cells(rng.Row, 4).Value
        vRange$ = .Cells(rng.Row, 5).Value
        vPlcHolder = .Cells(rng.Row, 6).Value
    End With

    'Export tables to PPT
             wb.Activate
             Sheets(vSheet$).Activate
             Set expRng = Sheets(vSheet$).Range(vRange$)
             expRng.Copy
    
             Set sld = pre.Slides(1)

                  With shp
                      
                     sld.Shapes.Placeholders(vPlcHolder).Select msoTrue
                     sld.Shapes.PasteSpecial ppPasteBitmap
                   
                  End With
          
        Set sld = Nothing
        Set shp = Nothing
        Set expRng = Nothing
   
Next rng

Set pre = Nothing
Set ppt_app = Nothing

wb.Close False
Set wb = Nothing

End Sub

它可能不是最优化的代码，但至少它每次都能正常工作，而不会出现错误的地方。

再次感谢 cmets！