将图表从 Excel 复制到 PPT

Copying charts from Excel to PPT

我有一个 Excel 有多个 sheet,每个 sheet 有多个图表。 我想从一个Excel的特定sheet复制一个图表到PPT中的一个特定slideno;具有特定尺寸(即高度和宽度)和使用 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

我们如何通过上面的代码单独改变图表的位置。

需要一些指导

这可能对你有帮助:

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