使用VBA从Excel复制/粘贴到PowerPoint时的定位和大小调整问题
使用VBA从Excel复制/粘贴到PowerPoint时的定位和大小调整问题
提问于 2021-01-28 17:33:56
我需要使用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。
这是我的第一篇文章，所以我希望我已经讲得足够清楚了。提前感谢您未来的回复。
Stack Overflow用户
回答已采纳
发布于 2021-01-29 18:44:33
感谢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这可能不是最优化的代码，但至少它每次都能正常工作，而不会出现在错误的地方。
再次感谢您的评论！
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/65934413
复制相关文章
相似问题
腾讯云开发者
