copy/paste 的位置和大小问题从 Excel 到 PowerPoint VBA

Question

我需要使用 VBA 命令将 excel 中的表格 copy/paste 转换为 powerpoint。

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

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

然而，当我运行副手时，前两个表格的位置和大小都正确，但在第三个表格之后，它们都进入幻灯片的中间，我应用的宽度也发生了变化。我发现当您 copy/paste 从 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 sheet 范围内有宽度、高度等所有属性... 如果相关的话，我也在 excel 和 powerpoint 2013。

这是我的第一个 post，所以我希望我已经足够清楚了。预先感谢未来的回复。

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

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

再次感谢您的意见！

copy/paste 的位置和大小问题从 Excel 到 PowerPoint VBA

Position and sizing issue with copy/paste from Excel to PowerPoint with VBA

excel

powerpoint

vba