vba 使用vba从excel中的每张幻灯片上创建一个带有多个图表的powerpoint

Creating a powerpoint with multiple charts on each slide from excel using vba

提问by Mike

I currently have a working code that takes each chart from my excel spreadsheet and creates a PowerPoint presentation that puts all of my charts on the same slide. I would like the macro to put four (4) charts on each slide but I am having trouble, any help is appreciated.(note- I haven't adjusted the size of the charts once they are in PowerPoint, I will handle this after I get 4 in each slide) My current code is as seen below

我目前有一个工作代码，它从我的 excel 电子表格中获取每个图表并创建一个 PowerPoint 演示文稿，将我的所有图表放在同一张幻灯片上。我希望宏在每张幻灯片上放置四 (4) 个图表，但我遇到了问题，不胜感激。（注意 - 一旦它们在 PowerPoint 中，我还没有调整图表的大小，我会在之后处理这个问题我在每张幻灯片中得到 4 个）我当前的代码如下所示

  Private Sub CommandButton17_Click()
'Add a reference to the Microsoft PowerPoint Library by:
'1. Go to Tools in the VBA menu
'2. Click on Reference
'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay

 'keep button in same location
 Set btn = ActiveSheet.Shapes("CommandButton17")
With btn
btLeft = .Left
btTop = .Top
End With

'First we declare the variables we will be using
    Dim newPowerPoint As PowerPoint.Application
    Dim activeSlide As PowerPoint.Slide
    Dim cht As Excel.ChartObject

 'Look for existing instance
    On Error Resume Next
    Set newPowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

'Let's create a new PowerPoint
    If newPowerPoint Is Nothing Then
        Set newPowerPoint = New PowerPoint.Application
    End If
'Make a presentation in PowerPoint
    If newPowerPoint.Presentations.Count = 0 Then
        newPowerPoint.Presentations.Add
    End If

'Show the PowerPoint
    newPowerPoint.Visible = True
'        newPowerPoint.ActivePresentation.ApplyTemplate _
'            "D:\Documents and Settings\austin.plantz\Desktop\Misc Projects\CSA PP Theme.thmx"

'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
    For i = 1 To ActiveSheet.ChartObjects.Count
        Set cht = ActiveSheet.ChartObjects(i)

'            With ActivePresentation.SlideMaster
'                .CustomLayouts.Add (1)
'                .CustomLayouts(1).Name = "Title And Content"
'            End With

    'Add a new slide where we will paste the chart
    If i - 1 Mod 4 = 0 Then
        newPowerPoint.ActivePresentation.Slides.Add  newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitle
    End If


       newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
        Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    'Copy the chart and paste it into the PowerPoint as a Metafile Picture
        cht.Select
        ActiveChart.ChartArea.Copy
        activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select

    'Set the title of the slide the same as the title of the chart
        'activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

    'Adjust the positioning of the Chart on Powerpoint Slide
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 165
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 150
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 400

        activeSlide.Shapes(2).Width = 200
        activeSlide.Shapes(2).Left = 505

        activeSlide.Shapes(1).Top = 25

    Next

AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing

End Sub

采纳答案by user1429899

First change you ForEach loop to For

首先将您的 ForEach 循环更改为 For

For i = 1 To ActiveSheet.ChartObjects.Count
Set cht = ActiveSheet.ChartObjects(i)

Then put condition before creation of slides:

然后在创建幻灯片之前放置条件：

chartNum = (i - 1) Mod 4
If chartNum = 0 Then
    newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutTitle
End If

Then, put logic for placing charts on each slide :

然后，在每张幻灯片上放置图表的逻辑：

  If chartNum = 0 Then
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 50
    ElseIf chartNum = 1 Then
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 300
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 50
    ElseIf chartNum = 2 Then
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 50
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300
    Else
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 300
        newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 300
    End If

    newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 200
    newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 200

Of course, play with lefts, tops, heights and widths yourself.

当然，你可以自己玩左、上、高度和宽度。

回答by ViNN

dont forget to use this before setting Width or Height of chart:

在设置图表的宽度或高度之前不要忘记使用它：

sr.LockAspectRatio = msoFalse

Here srstands for PPApp.ActiveWindow.Selection.ShapeRange

这里sr代表PPApp.ActiveWindow.Selection.ShapeRange

回答by user5389392

Option Base 1

Sub CreatePowerPoint()

        Dim newPowerPoint As PowerPoint.Application
        Dim activeSlide As PowerPoint.Slide
        Dim cht As Excel.ChartObject


        On Error Resume Next
        Set newPowerPoint = GetObject(, "PowerPoint.Application")
        On Error GoTo 0


        If newPowerPoint Is Nothing Then
            Set newPowerPoint = New PowerPoint.Application
        End If

        If newPowerPoint.Presentations.Count = 0 Then
            newPowerPoint.Presentations.Add
        End If

    'Show the PowerPoint
        newPowerPoint.Visible = True


            newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
            newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
            Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

Dim left1(8)
Dim top1(8)
left1(1) = 20: top1(1) = 70
left1(2) = 350: top1(2) = 70
left1(3) = 20: top1(3) = 300
left1(4) = 350: top1(4) = 300
left1(5) = 20: top1(5) = 70
left1(6) = 350: top1(6) = 70
left1(7) = 20: top1(7) = 300
left1(8) = 350: top1(8) = 300

n = ActiveSheet.ChartObjects.Count

  nn = WorksheetFunction.RoundUp(n / 4, 0)

  g = 1

    For pp = 1 To nn

        p = g
        t = p + 3

        x = 1

        For h = p To t

            On Error Resume Next
            ActiveSheet.ChartObjects(h).Select
            ActiveChart.ChartArea.Copy
            newPowerPoint.ActiveWindow.ViewType = ppViewSlide
            activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
            Application.CutCopyMode = False
            With activeSlide.Shapes(x)
                .Width = 150
                .Width = 200
            End With
            With newPowerPoint.ActiveWindow.Selection.ShapeRange
                .Left = left1(x)
                .Top = top1(x)
            End With
            x = x + 1

        Next
        g = t + 1



         newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
            newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
            Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
            newPowerPoint.ActiveWindow.ViewType = ppViewSlide

Next


    AppActivate ("Microsoft PowerPoint")
    Set activeSlide = Nothing
    Set newPowerPoint = Nothing

End Sub