将图表从Excel复制到PPT

Question

我有一个Excel，里面有多张表，每张表都有多个图表。我想从Excel的特定表格中复制一张图表，到PPT中的特定幻灯片；具体尺寸(即高度和宽度(和位置使用VBA。

我也能做到。

然而，当我试图这样做的时候；ppt中的其他形状也与图表一起被重新定位到相同的位置。

这是我的代码

wkbk.Sheets("Sheet2").Shapes("chart1").Copy
ActivePresentation.Slides(1).Shapes.Range.Height = embededpicrange.Cells(1, 3).Value
ActivePresentation.Slides(1).Shapes.Range.Width = embededpicrange.Cells(1, 4).Value

我们如何用上面的代码单独更改图表的位置。

需要一些关于的指导

Answer 1

这可能会对您有所帮助：

Sub copyChartToPP()
'Declare the needed variables
Dim newPP As PowerPoint.Application
Dim currentSlide As PowerPoint.Slide
Dim Xchart As Excel.ChartObject
'Check if PowerPoint is activate:
On Error Resume Next
Set newPP = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Open PowerPoint if not activate
If newPP Is Nothing Then
Set newPP = New PowerPoint.Application
End If
'Create a new presentation in powerPoint
If newPP.Presentations.Count = 0 Then
newPP.Presentations.Add
End If
'Display the PowerPoint presentation
newPowerPoint.Visible = True
'Locate Excel charts to paste into the new PowerPoint presentation
For Each Xchart In ActiveSheet.ChartObjects
'Add a new slide in PowerPoint for each Excel chart
newPP.ActivePresentation.Slides.Add newPP.ActivePresentation.Slides.Count + 1, 
ppLayoutText
newPP.ActiveWindow.View.GotoSlide newPP.ActivePresentation.Slides.Count
Set currentSlide = 
newPP.ActivePresentation.Slides(newPP.ActivePresentation.Slides.Count)
'Copy each Excel chart and paste it into PowerPoint as an Metafile image
Xchart.Select
ActiveChart.ChartArea.Copy
currentSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'Copy and paste chart title as the slide title in PowerPoint
currentSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'Adjust the slide position for each chart slide in PowerPoint. Note that you can 
'adjust the values to position the chart on the slide to your liking
newPP.ActiveWindow.Selection.ShapeRange.Left = 25
newPP.ActiveWindow.Selection.ShapeRange.Top = 150
currentSlide.Shapes(2).Width = 250
currentSlide.Shapes(2).Left = 500
Next
End Sub